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Abstract 

The goal of this paper is to give a preliminary formalization of the p-adic numbers, 
in the context of the Univalent Foundations. We also provide the corresponding code 
verifying the construction in the proof assistant Coq. Because work in the univalent 
setting is ongoing, the structure and organization of the construction of the p-adic 
numbers we give in this paper is expected to change as Coq libraries are more suitably 
rearranged, and optimized, by the authors and other researchers in the future. So 
our construction here should be deemed as a first approximation which is subject to 
improvements. 

1 Introduction 

In this paper we present a preliminary formalization of the construction of the p-adic num- 
bers in the Coq proof assistant. The formalization is carried out in the univalent setting 
introduced by the second author [ ]. This setting, which is based on insights from homo- 
topy theory and higher-dimensional category theory, serves as an overall organizational and 
methodological framework which informs our construction. At the same time, our construc- 
tion has several ingredients which are familiar in constructive mathematics. Because work 
on formalization in this direction is ongoing, the Coq code associated with this paper may 
be updated accordingly in the future by the authors and others. As such, the structure and 
content of the Coq code described here may not match exactly the code which is ultimately 
included in the Univalent Foundations libraries. Readers interested in making use of the 
code should accordingly consult the latest version available. 

We chose to formalize the p-adic numbers as a first step in the development and for- 
malization of the p-adic theory of integrable systems. We hope that this will prove to be a 
promising approach to this theory which should facilitate progress in the field in the future, 
in particular with regard to the construction of algorithms and their numerical analysis. 
Ultimately, we hope that insights from this project could be useful in the setting of real 
integrable systems. 

The idea of the univalent perspective is, roughly, to develop mathematics within the 
world of homotopy types. By virtue of taking this approach we are able to make use of 
type theory as a calculus for formal reasoning about homotopy types. We hope that in the 
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future, because this development of mathematics can be carried out in a proof assistant 
such as Coq so that the proofs carry some algorithmic content, it will be possible to extract 
good algorithms from the proofs. One of our motivations is that the construction of such 
algorithms would in turn help with some problems concerning integrable systems which 
are of particular interest in applications. For instance, one outstanding problem is: given 
numerical spectral data about a quantum system (coming from an experiment), extract an 
algorithm to reconstruct the classical integrable system, see Section 7. 

We will only briefly touch upon the technical details of homotopy type theory and the 
univalence axiom, and we refer the reader to [2] for a basic introduction to homotopy type 
theory. For univalent foundations and the second author's Coq library [18] we refer readers 
to [15], where a description of the research program, its motivations, and its implementation 
in Coq, are given. Because it is assumed that the reader is already familiar with Coq and 
with the second author's program, this paper has been written in a style which we foresee 
future papers in formalization taking: it is a summary of the Coq code written in ordinary 
mathematical English. The details are of course in the Coq code, but the overall structure of 
the formalization (as well as the key steps of the proofs) should be apparent from the sketch 
given here. The actual Coq code associated to this paper can be found on the websites of 
the authors, as supplementary files to the arXiv posting of this paper, and as an appendix 
to the present paper. 

Structure of paper 

Hensel [10] invented the p-adic numbers Qp about one hundred years ago. The p-adic numbers 
and the reals are the canonical metric completions of the rationals. Classically, there are a 
number of ways to construct the p-adic numbers, and we refer the reader to [8, 11, 16] for 
further details regarding the classical theory. The construction of the p-adic numbers given 
in this paper is constructive and uses algebraic, rather than analytic, techniques. Namely, 
we first construct the integral domain of p-adic integ ers as a quotient of the ring Zi[[X]] of 
formal power series over Z. We were unable to find the specific construction of Zp we employ 
in the literature, but we believe that it is known. We then take the p-adic numbers Qp to be 
the field of fractions of Zp. Because we are working constructively, and because Z[[X]] does 
not have decidable equality, it is necessary to work with an apartness relation and with the 
corresponding notions of integral domains and fields. We will refer to the apartness versions 
of fields as Heyting fields following the standard usage in constructive mathematics. 

In detail, this paper is organized as follows. In Section 2, we give a brief overview of 
the univalent setting. In Section 3 we review some basic constructive algebra. Section 4 
contains our construction of formal power series and the proofs of several results on formal 
power series. The proof that it is possible to form the Heyting field of fractions for an integral 
domain is given in Section 5. The construction of the p-adic numbers appears in Section 
6. Section 7 is a brief epilogue containing a sketch of some future plans concerning p-adic 
integrable systems. Finally, the Coq code can be found in the Appendix 7.2. Although this 
appendix is quite long, it is the most important part of the paper and so we feel that it is 
justified to include it here. 
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We should note that the p-adic numbers are also relevant in the physics literature, see 
[5] and the references therein. In fact, one of our main motivations in wanting to develop a 
p-adic theory of integrable systems is to study inverse spectral problems concerning p-adic 
analogues of real quantum integrable systems. We refer to Section 7.2 for a list of short term 
plans concerning the p-adic numbers. 

2 Univalent basics 

The second author's Coq library span a large portion of mathematics and we make free use 
of this library. However, for the sake of clarity we will here mention those specific parts of the 
library which we use in the construction of the p-adic numbers. A survey of the development 
of univalent mathematics in Coq can be found in [15]. 

Notation and conventions 

In this paper, and in the Coq files, all rings are assumed to be commutative and with 1. 

N denotes the type of natural numbers which is defined as an inductive type in the 
standard way. In the Coq code N is denoted by nat. Similarly, Z denotes the type of 
integers which is constructed as the group completion of the abelian monoid of natural 
numbers. In the Coq code Z is denoted by hz. 

lA denotes a fixed universe of types. In the Coq code this is denoted by UU. The identity 
type Id^(a, 6) is denoted by a ^ 6. In the Coq files this is denoted by either paths a 6 or 
by a ~> h. 

We write Hx A -Bi^x) for dependent products and Ylx A -B^x) for dependent sums (defined 
here as the record type total2). 

We will generally use the same naming conventions as used in the Coq files, but in some 
cases we will introduce abbreviations, such as Yl^=o /(^) summation, when it will improve 
the readability. 

Because the current implementation of the underlying tj^e system of Coq does not handle 
universes (and several related matters) in a way which is completely suited for the univalent 
development of mathematics, it is necessary to apply several patches to the Coq system in 
order to compile the second author's Coq library as well as the files described in this paper. 
Instructions on how to compile a patched version of Coq can be found in the second author's 
library. 

2.1 Basic homotopy theoretic notions in Coq 

We think of U as the universe of small homotopy types (or fibrant and cofibrant spaces). For 
B : U, we represent a dependent type over i? as a term E : B ^ lA. From the perspective 
of homotopy theory this corresponds to a fibration over B and, for h : B, E[h) corresponds 
to the fiber over h. The dependent product B{x) is regarded as the space of sections 
of the fibration represented by E. Similarly, the dependent sum, YIx-b B{x) corresponds to 
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the total space of the fibration. We think of the identity type a 6 as denoting the fiber 
of the path space over (a, 6). We will use the phrases "path space" and "type of paths" 
interchangeably for this type. I.e., a term / : a -w 6 corresponds to a path from a to h. 

Given a path f : b h' m B and a point e : E{h) in the fiber over h we obtain a 
corresponding point /1(e) : E{b') in the fiber over h' . In the Coq code f\ is denoted by 
transportf E f e. In order to construct a path x y in the total space Y1x-b -^(^) it 
suffices to construct a path / : 7ri(a;) TTi^y) and a path g : f\{Tr2{x)) 7i"2(y)- 

Given a term g : B ^ A and a path f : b b' in B, we obtain a path : g{b) (/(fo'). 
In the Coq code g{f) is denoted by maponpaths g f. This corresponds, regarding a homotopy 
type as an 00-groupoid, the weakly functorial action of g on the path /. 

Definition 2.1 (hf iber). Given types A and B, g : B ^ A and a : A, the homotopy 
fiber of g over a is the type 



Definition 2.2 (iscontr). We define the type iscontr(y4) of proofs that A is contractible 

as 



We say that A is contractible if iscontr(A) is inhabited. 

We will see below that contractibility in this setting plays the same role as canonical 
existence in the classical development of mathematics. 

Definition 2.3 (isweq and weq). Given g : B ^ A we define the type isweq((7) of proofs 
that g is a weak equivalence as 



If isweq(5f) is inhabited, then we say that g is a weak equivalence. 

There is a filtration of types into different "h- levels". Homotopy theoretically this is a 
slight extension of the usual filtration by homotopy n-types. We will only require the first 
few h-levels in this paper. 

Definition 2.4 (isofhlevel, isaprop, hprop, isaset and hset). A type A is of h-level:^ 

• if A is contractible; 

• {n + 1) if, for all a,b : A, the type (a b) is of h-level n. 

^Note that in order to define isofhlevel as a type which has values in U, as is done in the file uuO.v 
from the second author's Coq library, it is necessary to compile Coq with a patch. 




x:B 




c:A x:A 



isweq(5f) := J^J^ iscontr (hfiber g x). 

x:A 
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We denote by the type of proofs that A is of h- level n. We abbreviate ii{A) by 

isaProp(A) and i.2{A) by isaSet(yl). We write hProp for the type of (small) types of 
h- level 1 and hSet for the type of (small) types of h-level 2. 

Intuitively, hProp consists of those spaces which are homotopy equivalent to either the 
empty space or to the one element space 1. Accordingly, hProp plays the role played by 
the Boolcans in classical logic or by the subobject classifier in topos logic. Types in hProp 
satisfy proof-irrelevance (proof irrelevance) and, indeed (invproof irrelevance), being 
an h-prop is equivalent to being proof- irrelevant. 

Intuitively, hSet consists of those spaces which are homotopy equivalent to discrete 
spaces. I.e., these are the sets. Most of the types which we will be dealing with are either 
h-props or h-sets. We will sometimes refer to h-sets simply as "sets" when no confusion will 
result. 

We make use of a number of basic properties of h- levels. E.g., 

1. impred: for n : N, B : U and E : B ^U, the type 

isofhleveI„(£'a;) isofhleveln(]^ Er^.) 

x:B x:B 

is inhabited. 

2. impredf un: for n : N, A, 5 : if A is of h-level n, then so is {B ^ ^4). 

3. isof hleveldirprod: If A is of h-level n and B is of h-level n, then so is A x B. 

2.2 Function extensionality 

We make extensive use of the principle of function extensionality (funextfun), which follows 
from the second author's Univalence Axiom. 

Definition 2.5 (funextfun). The principle of function extensionality states that, for 
any two functions f,g:A^B, the type 

x:A 

is inhabited. 

2.3 Properties of hProp 

Given a type A : Z^, there is a universal way to turn A into a h-prop. This is the "inhabited" 
construction: 
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Definition 2.6 (ishinh_UU). We say that A :U is h-inhabited if the type 

P:hProp 

is inhabited. 

It is immediate, using the facts about h-levcls sketched above to see that A is an h-prop. 
Moreover, there is a projection tta '■ A ^ A given by 

T^A '■— K:A-^P:hProp-^f:A-^P-f{x). 

The map tta is the universal map from A into a h-prop. To sec this, observe that if Q is any 
h-prop and f : A ^ Q, then we have a commutative (up to definitional equality) diagram 

/ „ 

A 




A 

where 

/:=A,^.t(g)(/). 

Moreover, since Q is a h-prop it follows (using function extensionality) that the space of such 
extensions / is contractible. 

Using the h-inhabited construction it is possible to endow hProp with the structure of 
a Heyting algebra. This structure is summarized below: 

Definition 2.7 (htrue,hf alse,hconj,hdisj,hneg,himpl). For P^Q : hProp and X^Y -.U 
we define logical operations on hProp as follows: 

• 1 and are h-props. 

• P AQ -.^ P X Q. 

• XWY := xTy. 

• ^X -.^X ^0. 

• X ^ P :^ X ^ P. 

In addition to the Heyting algebra operations, there is an existential quantifier (hexists) 
which is defined by 

x:X 
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for any P : X ^ U and X : U. This quantifier satisfies the usual properties of the exis- 
tential quantifier in intuitionistic logic. Note that our 3 does not correspond to the built-in 
existential quantifier "exists" in Coq. 

The proof that, with the operations above, hProp is a Heyting algebra makes use of the 
Propositional Univalence Axiom (uaJip) which says that every logical equivalence between 
h- props induces a path between them. I.e., it says that the type 

n (p^Q)^ {{Q ^ p) ^ (p - Q)). 

P,Q:hProp 

is inhabited. 

2.4 Set quotients of types 

The second author has given several constructions of quotients of types. A hsubtype of a 
type A is given by a map S: A ^ hProp. Denote by V{A) the type of hsub types of A. 
Given a relation R on A (that is, R: A ^ A ^ hProp), an equivalence class consists of 
a subtype 5" of ^4 together with the following data: 

1. a term of type X^j..^ S{x). 

2. a term of type Ux,y:Ai^P-y ^ ^i^) ^ ^iv))- 

3. a term of type Yl,,^y.,A{S{x) S{y) ^ xRy). 

Given a subtype S, we denote by iseqclass^(S') the type consisting of such data. The set 
quotient A/R (setquot) of a type ^4 by a relation R is then defined by 

A/R:— ^ iseqclass^(S'). 

S:V{A) 

It is shown (isasetsetquot) in the second author's library that A/R is a. set and that, when 
R is an equivalence relation, this set has the usual universal property. In particular, there is 
a function n: A ^ A/R (setquotpr) which is compatible with the equivalence relation and, 
for any set B and function f : A ^ B which is compatible with R, there exists an extension 
/ making the diagram 

A/R ^----->B 




commute. We will make free use throughout of the results on set quotients from the second 
author's library. 
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3 Basics on constructive algebra 



We will here briefly recall some basics of constructive algebra. For a more detailed treatment 
we refer to [G] and [12]. 

The usual definitions of fields and integral domains are not entirely satisfactory from the 
perspective of constructive algebra since they deal with negative properties (the property 
of being a non-zero element of the field). From the constructive perspective, it is more 
appropriate to replace the notion of an element x being non-zero (x 7^ 0) with x being apart 
from zero, written x^O. 

We will now recall the basics regarding apartness relations. 

Definition 3.1. (isapart) A relation R : hRel(X) is an apartness relation provided that 
it satisfies the following conditions: 

Irrefiexive for all x : X, -^{xRx). 
Symmetric for all x,y : X, xRy implies yRx. 

Cotransitive for all x,y : X, if xRy, then either xRz or zRy, for any z : X. 

Classically, the negation of equality x ^ y relation is an apartness relation. However, 
negation of equality is not the only classical apartness relation. For example, if X is a 
topological space, then the relation R given by xRy if and only if x and y are in different 
connected components is an apartness relation. (This example can be generalized to give a 
limitless number of classical examples of apartness relations.) 

For X : hSet, we denote by Apart(X) the type of apartness relations on X. We generally 
denote apartness relations by xjj^y. When a type has decidable equahty the negation of 
equality is an apartness relation: 

Lemma 3.2 (deceqtoneqapart). If X : hSet has decidable equality, then negation of equal- 
ity 

-'{x y) 

is an apartness relation on X . 

Definition 3.3 (isapartdec). Given X : hSet and R : Apart(X), we say that i? is a 
decidable apartness relation on X if the type 

(aRb) + (a -w 6) 

is inhabited. 

It is immediate (isapartdectodeceq) that if i? is a decidable apartness relation on X, 
then X has decidable equality. 

When we are considering algebraic structures equipped with apartness relations we will 
require that the relation is compatible with the operations under consideration. In particular, 
for rings we have the following. 
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Definition 3.4 (acommrng). The type aCRng consists of commutative rings A together 
with an apartness relation x^^y on A which is compatible with the ring structure of A in 
the sense that'^ 

(i) For all a,b,c : A, if (c + a) # (c + 6), then a^b. 

(ii) For all a,b,c : A, if {c ■ a) ^ {c ■ b), then a # 6. 

When a commutative ring A has decidable equality it is straightforward to verify that 
negation of equality is compatible with the ring operations in the sense of Definition 3.4. 

Definition 3.5 (aintdom). The type aDom consists of A : aCRng such that 

• i#o. 

• For all a, 6 : A, if a # and 6 # 0, then {a-b)4f 0. 

We refer to the terms of type aDom as apartness domains. 

Heyting fields are the appropriate generalization of fields to the constructive setting when 
one considers algebraic structures with apartness relations: 

Definition 3.6 (af Id). The type aFld of Heyting fields consists of A : aCRng such that 

• i#o. 

• For all a : A, if a^O, then a has a multiplicative inverse (the type of multiplicative 
inverses of a is inhabited). 

We have the following immediate observation: 

Lemma 3.7 (af Idtoaintdom). If A is a Heyting field, then A is an apartness domain. 

Proof. It is immediate to prove that, in a Heyting field, if a has a multiplicative inverse, then 
it is apart from (af Idinvertibletoazero). It follows that 1 #0. One can show that if a 
and b both possess multiplicative inverses, then so does their product a-b (multinvmultstable) 
It is then immediate that {a ■ b) ^0 when a # and & # 0. □ 

4 Formal power series 

Our treatment of formal power series makes use of function extensionality, since formal 
power series over a commutative ring R are here defined as terms of type N R with the 
operations of addition and multiplication given in the usual way. The main result of this 
section is that, with these operations, formal power series is a commutative ring. Moreover, 
there is a natural apartness relation on formal power series and, furthermore, when the ring 
R has decidable equality the ring of formal power series over R forms an apartness domain. 
We will now fill in the details of this sketch. 

^Note that in the Coq files we actually require the corresponding cancellation properties also on the right. 
This is redundant for commutative rings, but for general rings one requires also these further properties. 
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4.1 Summation in a ring 



We define both a restrictive summation operation (natsummationO), which allows us to form 
the sum Yl^=o of ^ sequence a : N — )■ -R, and a more general operation (summation), which 
allows us to form the sum Yl^=m ^ sequence a : Z ^ R. However, we will only really 
require the former of these two constructions and so we will omit details related to the more 
general summation. In order to avoid confusion with our notation for dependent sums, we 
write ^^^Qtti for the sum J27=o^i- Summation is, of course, defined inductively by setting 

n+1 n 

^ai:=ao and ^ := a^) + a^+i. 

i=0 4=0 i=0 



Manipulation of sums 

It is important to note that when we manipulate sums, to obtain new sums, what is relevant 
is that there is a path between them, and not whether they are equal in the strict sense. This 
is a crucial point which underlies in a fundamental way much of the univalent approach to 
mathematics. The following lemma includes several basic facts regarding the behavior of 
summation of which we will make frequent use: 

Lemma 4.1. Given a natural number n and sequences a,b : N ^ R, we have the following: 

1. (natsummationpathsupperf ixed) Given p : rix Nl''' ^ ~^ {(^x b^), the type 

n n 

i=0 1=0 

is inhabited. 

2. (natsummationshif to) The type 

n+1 71 

0«i (0ai+i) + oq 

is inhabited. 

In order to more easily handle reindexing of sums we introduce, for / : N — )■ N, the 
type Aut„(/) (isnattruncauto) of proofs that / is an automorphism of the interval [0,n] 
of natural numbers. Explicitly, Aut„(/) is defined to be the following type:'^ 

(n E ((/(^) - ^) X n (/(^) - ^) ^ - ^))) X (H (/(^) ^ ^)) 

^a;<7i y<n z<n ^ x<n 

^Note that we could, alternatively, have used the type (na;<„ Z]j,<„ Uiv) ^)) ^ dlxKnUi^) - "))■ 
However, the more verbose type we give here is convenient, for purposes of formalization, as it allows for 
more direct proofs of subsequent lemmas. 
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where we have abbreviated Hx-n < n) ^ ■ ■ ■ as Y[x<n ' ' ' ^x-n — 'T') x • • • 
as J2x<n ■ ■ ■ • is possible to reindex sums along such automorphisms, as shown by the 
following lemma: 

Lemma 4.2. (natsummationreindexing) Given a natural number n and a map / : N — >■ N 
such that Aut„(/) is inhabited, the type 

n n 

for any sequence a : N ^ R, is inhabited. 

The final fact regarding summation which we require is the following: 

Lemma 4.3. (natsummationswap) Given f : N ^ N ^ R and a natural number n, the 
type 

n k n n—k 



fc=0 1=0 fc=0 1=0 

is inhabited. 



4.2 The ring of formal power series 

We define, for a type A, the type of sequences of elements of A (seqson) as the function 
space N — > A. When A is a set so is N — )■ A and for A a commutative ring we take N — )■ A 
as the underlying set (f ps) of the ring of formal power series over A. If a is a sequence on 
A, then we write a„ : A for the result of evaluating the sequence at the natural number n. 



Ring operations on formal power series 

For a given commutative ring i?, addition and multiplication of formal power series are 
defined as usual by the formulae: 

(a + b)n := an + bn 

n 

{a ■ b)n := ©afe6„-fe. 

k=0 

The zero sequence is given by 0„ := for all natural numbers n and the sequence 1 is given 
by lo := 1 and l„+i := for all natural numbers n. 

Proposition 4.4 (fpscommrng). Let (i?, +, •) be a commutative ring. Then the set of se- 
quences on R with the operations given above is a commutative ring. 
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Proof. The proof follows from the facts about summation described above. For example, to 
prove associativity of multiplication, we must show that, for all natural numbers n, 



n n-j 



) 




a,- ■ ( ■ C(„_j) 



i=0 k=0 



j=0 1=0 



For this, we reason as follows 



n n—j 



n 



n 



00a,- ik ■ C(„_,)_z) - 0(a, • ■ 



c, 



■n—l— 



^00«'-(^' 



j=0 1=0 1=0 j=0 



1=0 j=0 



where the first path is given by Lemma 4.3 and associativity of multiplication in R. In the 
Coq proof this line of reasoning is put together with generous use of Lemma 4.1, (f unextf un), 
several minor lemmas such as (natsummationtimesdistl), and associativity of R itself. □ 

4.3 The apartness relation on formal power series 

Although it is not used in the construction of the p-adic numbers, we mention here some 
results contained in the Coq files regarding apartness relations on formal power series. 

Assume that i? is a commutative ring with an apartness relation. Then there is an 
induced apartness relation on -R[[X]] given by setting (fpsapart) 



for a,b : -R[[X]]. This apartness relation is compatible with the ring operations and so we 
see that : aCRng (acommrngf ps). 

For R an apartness domain, provided that the apartness relation on R is decidable in the 
sense of Definition 3.3, it is possible to show that -R[[^]] is an apartness domain. 

Proposition 4.5 (apartdectoisaintdomf ps). For R : aDom with decidable apartness, the 
commutative ring R[[X]] of formal power series is an apartness domain when equipped with 
the apartness relation (1). 

The proof of Proposition 4.5 is a consequence of the following lemma: 

Lemma 4.6 (leadingcoef f icientapartdec). For R : aDom and a : if ao^O, 

then for any n : N and b : if bn # 0, then {a ■ b) ^ 0. 

Proof. The proof is by induction on n and is obvious in the base case. The induction 
case splits into two subcases depending on whether 6o # or 6o 0. In the former case, 
(a ■ 6)o # 0, whereas in the latter case the claim follows by applying the induction hypothesis 
to the sequence b' : given by b'„ := bn+i- □ 



a^b if and only if 3„.N.a„ # b. 



n 



(1) 
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5 The Heyting field of fractions 



The construction of the Heyting field of fractions from an apartness domain is a classical 
result in constructive algebra due to Heyting and we therefore give only a brief sketch of the 
details here. 

Definition 5.1 (aintdomazerosubmonoid). Given A : aDom, we denote by A the sub- 
monoid of A (with respect to the multiphcative structure of A) consisting of those a : A such 
that a#0. 

It follows (commrngf rac) that there exists a commutative ring y4[A^^] obtained by lo- 
calizing with respect to A. It remains to show there exists an apartness relation on 
which makes it into a Heyting field. 

Definition 5.2 (af Idf racapartrelO). For elements a,c : A x A we define 
a#c if and only if ((vria) ■ (vr2c)) ^ ((vic) ■ (7120)). 

This relation extends to a relation (af Idf racapartrel) on and it is straightfor- 

ward to show that it is an apartness relation (af Idf racapart) which is compatible with the 
ring structure of (af IdfracO). For instance (iscotransaf Idf racapartrelpre), to 

see that it is cotransitive suppose given {a,a') {c,c') and some {b,b'). Then, by the fact 
that A is an apartness domain, we see that a ■ c' ■ b' ^ c ■ a' ■ b' . Therefore, by cotransitivity 
of the apartness relation of A, we have that either a ■ c' ■ b' ^b ■ a' ■ c' or b ■ a' ■ c' ^ c - a' ■ b' . In 
the former case it follows that a - b' ^b ■ a'. I.e., (a, a') # (6, b'). In the latter case it similarly 
follows that (6,6')#(c,c'). 

Given a & Ax A such that a # 0, we have 7ri(a) # and therefore, we take to be given 
by the pair (712(0), 7ri(a)). This definition extends to a definition of the inverse of an element 
apart from in ^[A"^] and it is straightforward to show that this gives makes y4[y4~^] a 
Heyting field: 

Theorem 5.3 (af Idf racisaf Id). For A : aDom, with the definitions given above, A[A^^] 
forms a Heyting field. 

We refer to the Heyting field from Theorem 5.3 as the Heyting field of fractions of 
A and we write Prac(A) for it. 

6 The p-adic numbers 

The p-adic numbers were invented about one hundred years ago by German mathematician 
K. Hensel. 
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6.1 Basic number theory 

The following definition is the relation of integer divisibility, and is given as a two part 
definition in the Coq file. The first part says that, given three integers n, m, k, if the product 
of n and k is m, then n divides m. The general definition starts only with n and m, and 
appeals to the existence of k. 

Definition 6.1 (hzdivO and hzdiv). Let n and m be integers. We write n\m for the type 

n\m := 3fc.2.(m n ■ k) 
and we say that n divides m when n|m is inhabited. 

The division algorithm is then shown to hold via a series of steps. First, we prove the 
division algorithm for natural numbers. Recall that prl and pr2 are defined as projections 
onto the base and "specialization" to a fiber: 

Lemma 6.2 (divalgorithmnonneg). Forn andm of type na.t, withm nonzero, there exists 
a term qr : {Z x Z) such that there is a term of type 

n {m ■ vri(gr)) + 7r2(gr) 

and there are proofs that < ii2{qr) < m. 

The proof of Lemma 6.2 is by induction on n with, in the successor step, a case analysis 
on whether (r' + 1) < m or r' m (that such a case analysis is possible follows from 
decidability of equality using hzlehchoice from the second author's library). The proof of 
the general division algorithm is then done by a detailed case analysis (on whether n and m 
are negative, non- negative or propositionally equal to 0): 

Theorem 6.3 (divalgorithmexists). For n and m of type Z with m > 0, the space of 
terms qr : Z x Z such that the types n {m ■ vri(gr)) + TT2{qr) and < vr2(gr) < \m\ are 
inhabited is contractible. 

Here, as throughout, contractibility corresponds to unique existence in the traditional 
setting. One consequence of the division algorithm is that we obtain the operations of taking 
the quotient and remainder of an integer modulo a non-negative integer (hzquotientmod and 
hzremaindermod). These two operations will play a role in a number of calculations in the 
sequel. 

In addition to the division algorithm we also obtain the familiar Euclidean algorithm 
(again stated in terms of contractibility of an appropriate space): 

Theorem 6.4 (euclideanalgorithm). Let n and m be integers with n ^ 0. Then the space 
hzgcd(ri,m) of greatest common divisors of n andm is contractible. 

We also obtain a form of the Bezout lemma: 
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Lemma 6.5 (bezoutstrong). For all m,n : Z such that n is non-zero, the type ofab:'Zx'Ij 
for which there exists a term of type gcd(n, m) 7ri(a6) ■ n + TT2{ab) ■ m is inhabited. 

Given p : Z, the type of proofs that p is a prime is defined by setting 

isaprime(p) := (1 < p) x ((m|p) — )■ (m -w 1) V (m -w p)). 

As a consequence of Lemma 6.5 we obtain 

Theorem 6.6 (acommrng_hzmod and ahzmod). For non-zero p of type Z, Z/pZ is a com- 
mutative ring with compatible apartness relation. When p is a prime, Z/pZ is a Heyting 
field. 

Note that the apartness relation on Z/pZ is the one induced by the fact that equahty of 
Z/pZ is decidable (isdeceqhzmodp). 

6.2 The construction of Qp 

Throughout this section we assume given a prime p. Exphcitly, we require the proof wit- 
nessing the fact that p is a prime. We note though that for some of the results stated here 
it is only necessary that p be non-zero. We also introduce some notation for quotients and 
remainders modulo p. We denote by {a} the quotient of a modulo p (hzquotientmod) and 
by [a] the remainder of a modulo p. 

We will now summarize our construction of the apartness domain Zp of p-adic integers. 

Definition 6.7 (precarry). Given a formal power series a over Z, we define a new formal 
power series p(a) over Z inductively by 

p(a)o := flo 
p(a)„+i := a„+i + {p(a)„}. 

Definition 6.8 (carry). Given a formal power series a over Z, we define a new formal power 
series over Z by 

(a'')„ := [p(a)„]. 
We call the carried power series of a. 

Example 6.9. The formal power series a = (4, 1, 8, 0, . . .) is sent to p(a) = (4, 2, 8, 2, 0, . . .) 
and to = (1,2,2,2,0,...). 

The operation of carrying (mod p) for power series induces an equivalence relation ~ 
(carryequiv) on Z[[X]] by setting 

a b if and only if a'' fe''. 
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Observe that X — p ~ 0. Furthermore, for any a G Z[[X]], if a ~ 0, then there exist integers 
Aj such that Oq = — AoP and a„+i = —\n+iV + -^n- Using these facts it follows that ~ is the 
equivalence relation corresponding to the ideal {X —p) in Z[[X]]. Ultimately, once the theory 
of ideals has been developed in the Univalent Foundations Library, Zp will be constructed 
as the quotient of Z[[X]] by this ideal. However, because quotients of rings are given in the 
second author's library in terms of congruences, we here describe Zp using the corresponding 
congruence ~. 

We will now describe the proof that this relation is a congruence with respect to the ring 
operations on Z[[X]]. 

Lemma 6.10 (quotientprecarryplus). For formal power series a and h overZ, 
{p(a + 6)4 ^ {p(a)4 + {p(6)4 + {p(a^ + b^)^} 

for n : N. 

Proof. The proof is by induction on n. In the base case it is trivial and in the induction case 
it is by the following calculation: 

{p(a + h)n+i} ^ {p(a)n+i + p(&)n+i + {p(a^ + h^)n}] 

- {p(«)n+i} + [mn+i] + {p(a^ + h\] + {ai^, + hi^, + [p(a^ + h\]] 
^ {p(a)n+i} + {v{h)n+i] + {p(a^ + h\+i] 

where the first path is by definition of precarry and the induction hypothesis, the second 
path is by the familiar decomposition of the quotient of a sum, and the final path is by 
definition and the fact that the quotient of a remainder is zero. □ 

The following observation is a consequence of Lemma 6.10. 
Lemma 6.11 (carryandplus). For a and h formal power series overZ,, + -w + 

Similarly, a straightforward induction gives us the following lemma: 
Lemma 6.12 (precarryandtimesl). Given formal power series a and b over %, 

{p(a ■ ^ ({p(a)} ■ 6)„, + {p(a^ ■ 

for n : N. 

The proof that carrying is compatible with multiplication of power series is then an 
immediate consequence of Lemma 6.12: 

Lemma 6.13 (carryandtimes). Given formal power series a andb overZ, {a-b^ 



16 



It follows from Lemmas 6.11 and 6.13 that the quotient of by the equivalence 

relation ~ is itself a commutative ring (commrngof padicints). Indeed, it is the commutative 
ring Zp of p-adic integers. Moreover, there is an apartness relation (padicapart) on p-adic 
integers obtained as the extension of the relation (padicapartO) 

a#6 if and only if 3„:M.-'(a5j (2) 

for a, 6 : Z[[X]], to the p-adic integers. This apartness relation is straightforwardly seen to 
be compatible with the ring structure of Zp (acommrngof padicints). 

Theorem 6.14 (padicintsareintdoni,padicintegers). The commutative ring Zp with the 
apartness relation described above forms an apartness domain. 

Proof. It suffices to prove that for a,b : Z[[X]] such that a#0 and 67^0 it follows that 
a ■ b^O, where we are considering only the apartness relation (2). Since Z has decidable 
equality, it follows (leastelementprinciple) that there are natural numbers k and m which 
are the least natural numbers such that ~i(a^ 0) and ""(^m 0)' respectively. It then 
follows that -i((a ■ ~^ 0). 

To see this, assume for a contradiction that there is a path (a ■ b)'l_^_^ ^ and consider 
first the case where k + m = 0. Then we have that oq ■ &o is congruent to modulo p and 
therefore, since p is prime, either oq is congruent to modulo p or 69 is congruent to 
modulo p. In either case we have obtained a contradiction. 

On the other hand, when + m is a successor k + m = n + 1, we have that 

ia-b)l^^[{a^-b%^^ + {p{a^.b^t}]. (3) 

By the choice of k and m it follows that there is a further term (precarryandzeromult) of 
type p{a^ ■ 0. Therefore, we obtain a term of type 

0^[(a^-6^)fc+J. 

However, it is easy (hzf pstimeswhenzero) to see that (a^ ■ 6^)^+^ ^ a\. ■ b\^. So, since p is 
prime, either -w or feJn is inhabited. In either case we obtain a contradiction. □ 

Using Theorem 6.14, we now arrive at our definition of the p-adic numbers: 

Definition 6.15 (padics). The Heyting field Qp of p-adic numbers is defined as the Heyting 
field of fractions of Z^: 

Qp := Frac(Zp). 
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7 Future directions: towards p-adic integrable systems 



Next we present an outline of the work on p-adic integrable systems that we plan to carry 
out following this paper. The long term goal is to develop an analogue of the symplectic 
theory of finite-dimensional real integrable systems in [13, 11] for p-adic integrable systems 
in the univalent setting, and implement it in Coq. 

We are beginning to explore this, and what we give next is a brief and informal glimpse 
of our plans. At this point this section is a discussion without rigorous descriptions as we are 
not yet convinced of the optimal definition of p-adic integrable system. We hope to convey 
the fact that the p-adic and real theories are expected to be different, and draw attention to 
the topic; in fact, we are not aware of a uniform treatment of p-adic integrable systems in 
the symplectic setting. 

7.1 Definition of p-adic integrable systems 
A word on the contrast between p-adic and real notions 

We refer to [8, Section 3] for basic algebraic and topological aspects concerning the p-adic 
numbers. Many aspects do not match the intuition we have for the real numbers. For 
instance, there are no nontrivial connected sets and there are non-empty sets which are both 
compact and open. Other aspects are more familiar: on Qp there is an absolute value | ■ | 
and Qp is complete with respect to it, and there is an inclusion Q — )■ Qp with dense image. 
Continuity and differentiability of functions is defined in the usual way [s, Definitions 4.2.1, 
4.2.2]. Continuous functions are uniformly continuous on compact sets, as in the real case. 

The notions of continuity and differentiability extend to functions f : U G (Qp)" — Qp of 
several variables (xi, . . . , Xn) on open sets U of the Cartesian product (Qp)", in direct analogy 
with the real case, and in particular we have analogous definitions for partial derivatives 
for all i = l,...,n. But although the definitions are the same, differentiability behaves 
differently in the p-adic case than in the real case. For instance, there are functions / : Qp — )■ 
Qp which have zero derivative everywhere but are not locally constant. Also, the natural 
extension of the real mean value theorem to the p-adic case is false in general (although a 
version holds for sufficiently close points), as seen for instance by considering f{x) = — x 
between the extreme points a = and 6 = 1. In this case, [S, Proposition 4.2.3] /'(x) = 
pxP-^ — 1 and /(a) = f{b) = and it is easy to check that any element "in between" a and 
b, that is, of the form at + 6(1 — t) = 1—t for some t with |t| < 1, gives rise to a unit /'(I —t) 
in Zp. 

These differences are an indication that the theory of p-adic integrable systems is not 
expected to be a direct extension of the theory of real integrable systems, even if the basic 
definitions are analogous. One can explore such theory classically only, but we hope to do 
it in the univalent setting, building on the constructions of Qp which we have given in the 
previous sections. 
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Integrable systems 

We are here going to propose a notion of p-adic integrable systems in parallel with the 
commonly accepted notion of real integrable systems, at least in symplectic geometry. 

Because in the univalent foundations, and in Coq, it is nontrivial to define manifolds, for 
now we are going to work with the p-adic Cartesian product 

M := (Qp)^" = Qp X . . . (2n times) . . . x Qp 

with coordinates . . . ,Xn,yn)- In this way, we also avoid a discussion of differential 

or symplectic forms. Fix a p-adic measure on Qp, and endow M with the induced product 
measure. 

On M we may consider differentiable functions in the p-adic sense^. The following is the 
formal extension of the definition of real integrable system in finite dimensions. There is, 
however, a critical point which is not clear to us at the moment, and that's why we restrict 
our definition to analytic maps, see Remark 7.2. 

Definition 7.1. We will say that a (p-adic) analytic map F := (/i, . . . , /„) : M — )■ (Qp)" is 
a p-adic integrable system if two conditions hold: 

1. the collection /i, . . . , /„ satisfies Hamilton's equations: 

-A dfi dfj dfi dfj w 1 / • / ■ / fA\ 

^ dxk oyk oyk oxk 

2. the set where the n formal differentials 

dp- ■= ^ ^ ^\ V 1< ^ < n 

\dxi dxn oyi dyn^ 

are linearly dependent has p-adic measure 0. 

That is, there exists a p-adic measure set A such that d/i,...,d/„ are linearly 
independent on M \ A. The points where d/i,...,d/„ are linearly dependent are 
called singularities. 

Remark 7.2. This remark explains why we have to restrict to analytic functions in Definition 
7.1, when in the real theory one likes to include all smooth functions in the definition of 
integrable system. There are many interesting, nontrivial p-adic functions that are smooth 
and have zero derivative everywhere. However this is not possible if one restricts to analytic 
functions. Therefore if / is a smooth solution to a linear differential equation, we could add 
to / any of these nontrivial functions with zero derivative and obtain a new solution. It 
follows that all collections of n smooth functions /i, . . . , /„ which are smooth and have zero 
derivative everywhere would also form a kind of integrable system, but a very " degenerate" 
one (in the sense that the differentials d/i, . . . , d/„ would not be linearly independent almost 

^for now we are thinking only of polynomials on 27i-variables, which are easy to deal with in Coq. 
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everywhere as it is normally required for real integrable systems). So this undesirable case 
does not occur. However, adding functions with zero derivative to an existing system would 
be unavoidable, giving rise to a new, seemingly very different, p-adic integrable system. We 
currently understand neither what this means geometrically, nor what it implies for the 
development of the theory. 



7.2 Future plans 

The following is a rough outline of what we would like to do next. 



Towards p-adic symplectic geometry 

> p-adic manifolds: formalize the notion of p-adic manifold in the univalent Foundations 
with Coq. Formalize Serre's theorem [17] classifying compact p-adic manifolds. 

> p-adic symplectic forms: a p-adic symplectic form u may be defined as in the real 
case. The closedness condition dw = makes sense in the p-adic setting, and so does 
the non- degeneracy condition (in fact, over any field). In the real setting, a theorem 
of Darboux says that all symplectic forms are locally equivalent, so real symplectic 
manifolds have no local invariants. It is natural to wonder whether this result holds 
in the p-adic setting "as is". Because of our previous discussion (see Remark 7.2) one 
should probably restrict to the analytic setting since dcu = is in fact a system of 
partial differential equations. Darboux's theorem plays a leading role in the theory of 
real integrable systems. 



Towards p-adic integrable systems: basic theory 

> construction of p-adic integrable systems: define p-adic integrable systems on p-adic 
manifolds, not just (Qp)", and implement this in the univalent foundations using Coq. 

> p-adic local and semiglobal theory: develop the local and semilocal theory of p-adic 
integrable systems in Coq. The local theory basically refers to local models, and the 
semilocal theory refers to local models in neighborhoods of fibers. One is interested in 
both the topological and symplectic classification of such models. We are not aware of 
results describing the topological, or symplectic, structure of regular or singular fibers 
in the p-adic setting. 

In the real case, the regular fibers and their neighborhoods are understood (this is the 
famous Action- Angle Theorem due to Mineur and Arnold.) The singular fibers may be 
complicated and not are yet well understood in the real setting either (if one restrict 
to the real analytic setting, then the theory is better understood). 
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Towards p-adic toric and semitoric systems 

> p-adic toric systems: a particular class of real integrable systems which has been 
thoroughly studied and is well understood, is that of toric integrable systems F = 
(/i, . . . , /„) on 2?7,-dimensional compact symplectic manifolds {M,u). These are sys- 
tems in which each component fi generates a flow which is periodic of a fixed period. 
In this case, F is called a momentum map. Atiyah [i], Guillemin- Sternberg [ ] and 
Delzant [<] proved a series of striking theorems concerning these systems in the 1980s, 
which in particular led to complete combinatorial classification in terms of convex poly- 
topes by Delzant (these convex polytopes are nothing by the images of M under F). A 
theorem of Serre [ I / ] classifies compact p-adic analytic varieties. If on these varieties 
we would consider actions of the p-adic n-torus, we do not know to what extent the 
above results could be extended. If in Definition 7.1 one allows smooth non-analytic 
functions, these results would not hold (see Remark 7.2). 

> p-adic semitoric systems: give a classification of p-adic integrable systems under some 
periodicity condition in analogy with [13, 14]. 

Spectral questions for p-adic integrable systems 

Here we restrict to the systems in the previous section, for which we know that in the real 
full classification may be given. 

> Inverse spectral problems: construct algorithms to solve inverse spectral problems 
about quantum integrable systems. The leading question in the real case is: given the 
spectrum, can one recover the system from it? 

> Numerical implementation of inverse spectral problems: constructing numerically ac- 
curate algorithms to solve inverse spectral problems. 

The first subsection above should be within reach. We expect the second and third 
subsections to be substantial. The fourth one depends on the third and it is difficult to 
predict how complicated it will be. 
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Appendix: Coq code 



Disclaimer: The libraries summarized and listed below are in preliminary form and are 
actively being improved and extended by the authors and others. As such, we advise inter- 
ested readers to consult also with the most recent versions, which need not agree in form 
and content with the libraries described here. 

The Coq code is included in full below for easy reference by the reader. We also expect 
to make it available on the webpages of the first and third authors. For easy reference, we 
include here a brief sketch of the contents of each of the files. It is worth remarking that all 
of the files described here rely upon the second author's Coq library. For more on this library 
we refer the reader to the library itself and to the tutorial [15]. For quick reference. Figures 
1 and 2 give the dependences of the second author's library and the library associated with 
this paper, respectively. 

Of the new files, the file lemmas. v contains a number of small lemmas which, such as 
basic facts about apartness relations, some lemmas on rings, et cetera, which are required 
by the other files. The file fps.v contains all of the material on formal power series. The 
construction of the Heyting field of fractions can be found in frac.v. The basic number 
theoretic results which we require are in zmodp.v. Finally, the construction of the p-adic 
numbers is given in padics.v. 
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Figure 1: Dependence diagram of the second author's Coq library 
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Figure 2: Dependence diagram of the additional Coq files for the p-adics 
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7.3 The file lemmas. v 



(** *Fixing notation, terminology and basic lemmas *) 

(** By Alvaro Pelayo, Vladimir Voevodsky and Michael A. Warren *) 

{** Settings *) 

Add Rec LoadPath "../Generalities". Add Rec LoadPath " . ./hlevell" . 
Add Rec LoadPath " . . /hlevel2" . 

Unset Automatic Introduction. (** This line has to be removed for the 
file to compile with Coq8.2 *) 

(** Imports *) 

Require Export hSet . 

Require Export hnat . 

Require Export hz. 

(^Require Export f initesets . 

Require Export stnf sets . *) 

(** Fixing some notation *) 

{** * Notation, terminology and very basic facts *) 
bO Notation "x ~> y" := ( paths x y ) (at level 50 ) ; type_scope. 

Implicit Arguments tpair [TP]. 

Lemma pathintotalf iber ( B : UU ) ( E : B -> UU ) C bO bl : B ) ( eO : 
E bO ) C el : E bl ) ( pO : bO "> bl ) C pi : transportf E pO eO "> el 
) : ( tpair bO eO ) ~> C tpair bl el ) . Proof. intros. destruct pO, 
pi. apply idpath. Defined. 

Definition neq C X : UUO ) : X -> X -> hProp := fun x y : X => 
hProppair (neg (x ~> y)) (isapropneg (x "> y)). 

Definition pathintotalprl {B:UU}-[E:B->UU}-[vw: total2 E 
}Cp:v~>w) : { prl v ) "> { prl w ) maponpaths ( fun x prl 
X ) p. 

Lemma isinclisinj {AB :UU>{f : A->B]-(p : isincl f ) ■[ a b : 
A} (p : fa"'>fb) : a~>b. Proof, intros. set Cq :=p (fa) 
). set C a* := hfiberpair f a ( idpath (fa) ) ). set ( b' := 
hfiberpair f b ( pathsinvO pO ) ) . assert ( a' ~> b' ) as pi. apply ( 
p (fa) ) . apply C pathintotalprl pi ) . Defined. 

(** * I, Lemmas on natural numbers *) 

Lemma minusOr ( n : nat ) : minus n "> n. Proof. intros 
n. destruct n. apply idpath. apply idpath. Defined. 

Lemma minusnnO ( n : nat ) : minus n n ~> O/tnat. Proof, 
intro. induction n. apply idpath. assumption. Defined. 

Lemma minussnl ( n : nat ) : minus ( S n ) 1 ~> n. Proof, 
intro. destruct n. apply idpath. apply idpath. Defined. 



Lemma minussnlnonO ( n : nat ) ( p : natlth On) : S ( minus n 1 ) "> 



n. Proof. intro. destruct n. intro p. assert empty, exact ( 
isirref Inatlth 0%nat p ). contradiction, intro. apply 
maponpaths. apply minusOr. Defined. 

Lemma minusleh ( n m : nat ) : natleh { minus n m ) n. Proof, intros 
n. induction n. intros m. apply isref Inatleh. intros m. destruct 
m. apply isref Inatleh. exact ( istransnatleh ( minus nm)n(Sn) ( 
IHn m ) C natlthtoleh n ( S n ) ( natlthnsn n ) ) ). Defined. 



Lemma minuslleh { n m : nat } ( p : natlth On) C q : natlth m ) ( 
r ; natleh n m ) : natleh ( minus n 1 ) ( minus ml). Proof . intro 
n. destruct n. auto, intros m p q r. destruct m. assert empty, exact ( 
isirref Inatlth 0°/„nat q ), contradiction, assert ( natleh n ra ) as 
a. apply r. assert ( natleh ( minus n O/^nat ) m ) as aO. exact ( 
transportf C fun x : nat => natleh x m ) ( pathsinvO C minusOr n ) ) a 
) . exact C transportf C fun x : nat => natleh ( minus n ) x ) ( 
pathsinvO C minusOr m ) ) aO ) . Defined, 

Lemma minuslth ( n m : nat ) C p : natlth On) C q : natlth m ) : 
natlth ( minus n m ) n. Proof, intro n. destruct n. auto, intros m p 
q. destruct m. assert empty, exact C isirref Inatlth O'^inat q 
). contradiction, apply C natlehlthtrans _ n _ ). apply C minusleh n m 
). apply natlthnsn. Defined. 

Lemma natlthsntoleh ( n m : nat ) : natlth m ( S n ) -> natleh m n. 
Proof. intro. induction n. intros m p. destruct m. apply 
isref Inatleh. assert ( natlth m ) as q. apply p. intro. unfold 
natlth in q, exact ( negnatgthOn m q ). intros m p. destruct m. apply 
natlehOn. apply ( IHn m ), assumption. Defined. 

Lemma natlthminusO { n m : nat } ( p : natlth m n ) : natlth ( minus 
n m ). Proof. intro n. induction n. intros m p. assert empty, exact 
( negnatlthnO m p ). contradiction, intros m p. destruct 
m. auto, apply IHn. apply p. Defined. 

Lemma natlthsnminussmsn C n m : nat ) ( p : natlth m n ) : natlth C 
minus (Sn)(Sm))CSn). Proof, intro. induction n. intros m 
p. assert empty, apply 

nopathsf alsetotrue. assumption, contradiction, intros m p. destruct 
m. assert ( minus (S (Sn) ) l~>Sn) asf. destruct 
n. auto, auto, rewrite f, apply natlthnsn. apply ( istransnatlth _ ( S 
n ) _ ). apply IHn. assumption, apply natlthnsn. Defined, 

Lemma natlehsnminussmsn ( n m : nat ) ( p : natleh m n ) : natleh ( 
minus (Sn) (Sm) ) (Sn). Proof. intro n. induction n. intros 
m p X. assert empty, apply nopathsf alsetotrue . assumption, 
assumption. Intros m p. destruct m. apply natlthtoleh. apply 
natlthnsn. apply ( istransnatleh _ ( S n ) _ ). apply 
IHn. assumption, apply natlthtoleh. apply natlthnsn. Defined. 

Lemma pathssminus ( n m : nat ) ( p : natlth m(Sn)) :S( minus n 
m ) ~> minus ( S n ) m. Proof, intro n. induction n. intros m 
p . destruct m . aut o , assert empty , apply nopathstruetof alse . apply 
pathsinvO. assumption, contradiction, intros m p. destruct 
m. auto, apply IHn, apply p. Defined. 

Lemma natlehsminus ( n m : nat ) : natleh ( minus (Sn)m) (S( 

minus n m ) ). Proof. intro n. induction n. intros m X. apply 

nopathstruetof alse . apply pathsinvO . destruct 

m. assumption, assumption, intros m. destruct m. apply 

isref Inatleh. apply IHn. Defined. 



Lemma natlthssminus -[ n m 1 : nat } ( p : natlth mCSn)) Cq,: 
natlth 1 C S C minus ( S n ) m ) ) ) : natlth 1 ( S C S n ) ). Proof, 
intro n. intros m 1 p q. apply ( natlthlehtrans _ C S C minus C S n ) 
m ) ) ) . assumption, destmct m. apply isref Inatleh. apply 
natlthtoleh. apply natlthsnminussmsn . assumption. Defined. 

Lemma natdoubleminus { n k 1 : nat } C p : natleh k n ) C q : natleh 1 
k ) : C minus n k) "> C minus C minus n 1 ) C minus k 1 ) ). Proof, 
intro n. induction n. auto, intros k 1 p q. destruct k. destruct 1. 
auto, assert empty, exact ( negnatlehsnO 1 q ). contradiction, 
destruct 1. auto, apply ( IHn k 1 ). assumption, assumption. Defined. 

Lemma minusnlehl C n m : nat ) C p : natlth m n ) : natleh m C minus n 
1 ). Proof. intro n. destruct n. intros m p. assert empty, exact { 
negnatlthnO m p ). contradiction. intros m p. destruct m. apply 
natlehOn. apply natlthsntoleh . change ( minus ( S n ) 1 ) with ( minus 
n ). rewrite minusOr. assumption. Defined. 

Lemma doubleminuslehpaths C n m : nat ) ( p : natleh m n ) : minus n C 
minus n m ) ~> m. Proof. intro n. induction n. intros m p. destruct 
C natlehchoice mOp)as[h|k]. assert empty, apply negnatlthnO 
with C n m ), assumption, contradiction. simpl. apply 
pathsinvO . assumption. 

intros. destruct m. simpl. apply minusnnO. change C minus ( S n ) ( 
minus n m ) ~> S m ) , rewrite <- pathssminus. rewrite IHn. apply 
idpath. assumption, apply C minuslth (Sn) (Sm) ). apply ( 
natlehlthtrans _ n ). apply natlehOn. apply natlthnsn. apply ( 
natlehlthtrans _ m ). apply natlehOn. apply natlthnsn. Defined. 

Lemma boolnegtrueimplf alse ( v ; bool ) C p : neg C v ~> true ) ) : v 
~> false . Proof . intros . destruct v . assert empty, apply 
p. auto . contradiction, auto . Defined. 

Definition natcoface ( i : nat ) : nat -> nat. Proof. intros i 

n. destruct C natgtb in), exact n. exact C S n ). Defined. 

Lemma natcofaceleh (in upper ; nat ) C p : natleh n upper ) : natleh 
C natcoface i n ) ( S upper ). Proof. intros. unfold 
natcoface. destruct C natgtb in), apply natlthtoleh. apply C 
natlehlthtrans _ upper ). assumption, apply natlthnsn. apply p. 
Defined. 

Lemma natgehimplnatgtbf alse ( m n ; nat ) ( p : natgeh n m ) ; natgtb 
m n ~> false. Proof. intros. unfold natgeh in p. unfold natgth in 
p. apply boolnegtrueimplf alse . intro q. apply p. auto. Defined. 

Definition natcof aceretract ( i : nat ) : nat -> nat. Proof. intros 
i n. destruct ( natgtb in), exact n. exact ( minus n 1 ). Defined. 

Lemma natcof aceretractisretract ( i : nat ) : funcomp ( natcoface i ) 
( natcof aceretract i ) "> idfun nat. Proof, intro i. apply 
funextfun. intro n. unfold funcomp. set C c := natlthorgeh n i 
). destruct c as [ h I k ]. unfold natcoface. rewrite h. unfold 
natcof aceretract . rewrite h, apply Idpath. assert ( natgtb i n ~> 
false ) as f . apply natgehimplnatgtbf alse . assumption. unfold 
natcoface. rewrite f. unfold natcof aceretract . assert ( natgtb i ( S 
n ) ~> false ) as ff . apply natgehimplnatgtbf alse . apply ( 
istransnatgeh _ n ). apply natgthtogeh. apply natgthsnn. assumption, 
rewrite ff. rewrite minussnl. apply idpath. Defined. 

Lemma isinjnatcof ace C i x y : nat ) : natcoface i x ~> natcoface i y 
-> X ~> y. Proof. intros i x y p. change x with ( ( idfun _ ) x 
). rewrite <- ( natcof aceretractisretract i ). change y with ( ( idfun 
_ ) y ). rewrite <- C natcof aceretractisretract i ). xmfold funcomp. 
rewrite p. apply idpath. Defined. 



Lemma natlehdecomp ( b a : nat ) : hexists ( fun c : nat => ( a + c 
)yinat ~> b ) -> natleh a b. Proof, intro b. induction b. intros a 
p. apply p. intro t. destruct t as [ c f ]. destruct a. apply 
isref Inatleh. assert empty, simpl in f . exact C negpathssxO { a + c 
) f ). contradiction. intros a p. apply p. intro t. destruct t as [ c 
f ]. destruct a. apply natlehOn. assert ( natleh a b ) as q. simpl in 
f . apply IHb . intro P . intro s . apply s . split with c . apply 
invmaponpathsS . assumption . apply q. Defined. 

Lemma natdivleh C a b k : nat ) ( f : C a * k )%nat ~> b ) : coprod C 
natleh a b ) ( b ~> 0%nat ). Proof. intros. destruct k. rewrite 
natmultcomm in f. simpl in f. apply ii2, apply 

pathsinvO. assumption, rewrite natmultcomm in f. simpl in f. apply 
iil . apply natlehdecomp. intro P. intro g. apply g. split with ( k * a 
) '/jiaX . as sumpt ion . Def ined . 

(** * II, Lemmas on rings *) 

□pen Scope rng_scope. 

Lemma rngminusdistr { X : commrng } ( a b c : X ) : a * (b - c) ~> (a 

* b - a * c) . Proof. intros. rewrite rngldistr. rewrite 
mgrmultminus . apply idpath. Defined. 

Lemma rngminusdistl { X ; commrng > ( a b c : X ) : (b - c) * a ~> (b 

* a - c * a) . Proof. intros. rewrite rngrdistr. rewrite 
rnglmultminus . apply idpath . Def ined . 

Lemma mult in vmult stable ( A : commrng ) Cab:A) Cp: multinvpair 
A a ) C q : multinvpair A b ) : multinvpair A C a * b ). Proof, 
intros. destruct p as [a' p ]- destruct q as [ b' q ]. split with ( 
b' * a' ). split, change C(Cb'*a')*Ca*b) )7,rng ~> ( 
Qmgunel2 A )). rewrite C rngassoc2 A b'). rewrite <- ( rngassoc2 A 
a' ). change C dirprod ( C a' * a )Tirng ~> C Qmgunel2 A ) ) ( ( a * 
a' )/irng ~> ( Srngunel2 A ) ) ) in p. change ( dirprod ( ( b' + b 
)'/.rng '> ( Srngunel2 A ) ) ( ( b * b' )'/.rng ~> ( i3rngunel2 A ) ) ) in 
q. rewrite <- ( prl q ). apply maponpaths, assert (a' *a*b~>l* 
b ) as f . apply C maponpaths C fun x x * b ) { prl p ) ) . rewrite 
rnglunax2 in f. assumption, chajige C(Ca*b)*{b'*a') )/irng 
~> C @rngunel2 A )). rewrite ( rngassoc2 A a), rewrite <- ( rnga5soc2 
A b ). change ( dirprod ( C a* * a )'/,rng ~> ( @rngunel2 A ) ) ( ( a * 
a' )%rng ~> ( @rngunel2 A ) ) ) in p. change ( dirprod C C b* * b 
)'/,rng ~> ( Srngunel2 A)) C(b*b' )*/jng ~> ( Qrngunel2 A ) ) ) in 
q. rewrite <- ( pr2 q ). rewrite ( pr2 q ). rewrite rnglunax2. apply 
p. Defined. 

Lemma commingaddinvunique ( X : commrng )(abc:X)Cp: Qopl X a 
b ~> Qrngunell X ) ( q ; Qopl X a c ~> Qrngunell X ) ; b ~> c. Proof, 
intros, rewrite ( pathsinvO ( rngrunaxl X b ) ). rewrite ( pathsinvO 
q ) . rewrite ( pathsinvO ( rngassocl X _ _ _ ) ) . rewrite ( rngcomml 
X b _ ). rewrite p. rewrite rnglunaxl . apply idpath. Defined. 

Lemma isapropmultinvpair ( X : commrng ) ( a : X ) : isaprop ( 
multinvpair X a ). Proof, intros. unfold isaprop. intros b c. 

assert ( b ~> c ) as f. destruct b as [ b b' ]. destruct c as [ c c' 
]. assert ( b ~> c ) as fO. rewrite <- ( @rngrunax2 X b ). change ( 
b * C @rngunel2 X ) ) with ( b * 1 ) %multmonoid . rewrite <- ( pr2 c' 
). change C Cb*(a*c) )*/jng "> c ) . rewrite <- C mgassoc2 X 
). change ( b * a )%rng with C b * a )yjnultmonoid. rewrite C prl b' 
). change ( ( Srngunel2 X ) * c ~> c )'/,rng. apply rnglunax2. apply 
pathintotalf iber with C pO := fO ) . assert ( isaprop ( dirprod (c * 
a ~> C ®rngunel2 X ) ) (a * c ~> ( Srngunel2 X )) ) ) as is. apply 
isofhleveldirprod. apply C setproperty X ) . apply C setproperty X 
). apply is. split with f. intros g. assert C isaset ( multinvpair 



X a ) ) as is. unfold multinvpair. unfold invpair. change isaset 
with C isofhlevel 2 ), apply isof hleveltotal2 . apply ( prl C prl ( 
rlgmultmonoid X ) ) ). intros. apply isofhleveldirprod. apply 
hlevelntosn. apply ( setproperty X ). apply hlevelntosn. apply ( 
setproperty X ). apply is. Defined. 

Close Scope mg_scope. 

(** * III. Lemmas on hz *) 

Open Scope hz_scope. 

Lemma hzaddinvplus (nm;hz) :-(n + ra)~>(C-n) + C- in) 
), Proof, intros, apply commrngaddinvunique with ( a := n + m ) , 
apply rngrinvaxl. assert ( (n+m)+(-n+-m) ~> Cn+-n+m 
+ - m ) ) as i. assert Cn+m+(-n+-m)~>(n+(m+C-n+ 

- m ) ) ) ) as iO. apply rngassocl. assert (n+Cm+(-n+-m) 
)~>Cn+(m+-n+-m)))asil. apply maponpaths. apply 
pathsinvO, apply rngassocl, assert Cn+Cm+-n+-m) ~> {n+ C 
-n+m+-m)))asi2. apply maponpaths. apply C maponpaths C fun 
X : _=>3: + -m) ). apply mgcomml . assert (n + C-n + m + -m) 
~> Cn+(-n+m) +-m) ) asi3. apply pathsinvO. apply 
rngassocl, assert Cn+(-n+ra) +-m~> {n+-n+m+-m) ) 
as i4. apply pathsinvO. apply C maponpaths C fun x : _=>x+-m) 

), apply rngassocl. exact ( pathscompO iO ( pathscompO il ( 
pathscompO i2 ( pathscompO i3 14 ) ) ) ) . assert {n+-n+m+-m 
~> ) as j . assert Cn+-n+m+-m~> CO+m+-m) ) as jO. 
apply C maponpaths ( fun x : _=>x+m+-m) ), apply rngrinvaxl. 
assert CO+m+-m~> Cm+-m) ) asjl. apply ( maponpaths ( fun 
X : _=>x + -m) ). apply mglunaxl. assert (m + -m*'>0) as 
j2. apply rngrinvaxl. exact C pathscompO jO C pathscompO jl j2 ) ). 
exact C pathscompO i j ). Defined. 

Lemma hzgthsntogeh C n m : hz ) ( p : hzgth ( n + 1 ) m ) : hzgeh n m. 
Proof, intros. set C c := hzgthchoice2 ( n + 1 ) m ). destruct c as 
[ h I k ]. exact p. assert ( hzgth n m ) as a. exact ( 
hzgthandplusrinv n m 1 h ) . apply hzgthtogeh. exact a. rewrite ( 
hzplusrcan n m 1 k ). apply isreflhzgeh. Defined. 

Lemma hzlthsntoleh ( n m ; hz ) C p : hzlth m ( n + 1 ) ) : hzleh m n. 
Proof. intros. unfold hzlth in p. assert ( hzgeh n m ) as a. apply 
hzgthsntogeh. exact p. exact a. Defined. 

Lemma hzabsvalchoice ( n ; hz ) : coprod ( 0%nat ~> C hzabsval n ) ) C 
total2 ( fun x : nat => S x ~> ( hzabsval n ) ) ). Proof, 
intros. destruct ( natlehchoice _ _ C natlehOn ( hzabsval n ) ) ) as [ 
1 I r ]. apply 112. split with ( minus ( hzabsval n ) 1 ). rewrite 
pathssminus. change ( minus C hzabsval n ) ~> hzabsval n ). rewrite 
minusOr, apply idpath. assumption, apply iil . assumption. Defined. 

Lemma hzlthminusswap ( n m : hz ) C p : hzlth n m ) ; hzlth ( - m ) ( 

- n ). Proof. intros. rewrite <- ( hzpluslO ( - ra ) ). rewrite <- ( 
hzrminus n ) . change ( hzlth Cn+-n+-m) (-n)). rewrite 
hzplusassoc. rewrite ( hzpluscomm ( -n ) ). rewrite <- 
hzplusassoc. assert C - n*'> CO + -n) ) asf. apply 

pathsinvO. apply hzpluslO. assert C hzlth Cn+-m+-n) (0+-n 
) ) as q . apply hzlthandplusr . rewrite <- ( hzrminus m ) . change ( m 

- m ) with { m + - m ). apply hzlthandplusr. assumption, rewrite <- f 
in q. assumption. Defined. 



Lemma hzlthminusequiv C n m : hz ) ; dirprod ( C hzlth n m ) -> C 
hzlth C ra - n ) ) ) C < hzlth ( ra - n ) ) -> ( hzlth n ra ) ) . 
Proof. intros. rewrite <- ( hzrminus n ). change ( n - n ) with C n + 
- n ). change ( m - n ) with ( m + - n ). split. Intro p. apply 
hzlthandplusr. assumption. Intro p. rewrite <- ( hzplusrO n 



) . rewrite <- C hzplusrO m ) . rewrite <- ( hzlminus n ) , rewrite <- 
2 ! hzplusassoc , apply hzlthandplusr . assumption . Defined . 

Lemma hzltbminus Cnmk:hz) (p: hzlth n k ) ( q : hzlth m k ) ( 
q' : hzleh m ) : hzlth ( n - ra ) k. Proof. intros. destruct C 
hzlehchoice Omq' ) as [1 I r]. apply { istranshzlth _ n _ ). 
assert ( hzlth (n-ra) (n+0) ) asiO, rewrite <- C hzrminus m 
) . cheinge C m - m ) with ( m + - m ) . rewrite <- C hzplusassoc 
). apply hzlthandplusr. assert ( hzlth Cn+0)Cn+ra))as 
iOO. apply hzlthandplusl . assumption, rewrite ( hzplusrO ) in 
iOO. assumption, rewrite hzplusrO in 

iO. assumption, assumption, rewrite <- r. change C n - ) with C n + 
- ). rewrite hzminuszero. rewrite ( hzplusrO n ). assumption. 
Defined. 

Lemma hzabsvalandminuspos ( n m : hz ) ( p : hzleh On) ( q : hzleh 
m ) : nattohz C hzabsval C n - m ) ) "> nattohz ( hzabsval C m - n ) 
) . Proof . intros . destruct ( hzlthorgeh nm) as [1 I r], assert 
C hzlth (n-m) 0) as a. change ( n - m ) with ( n + - m ) . 
rewrite <- ( hzrminus m ) , change C m - m ) with C ra + - ra ) . apply { 
hzlthandplusr ). assumption. assert C hzlth 0Cm-n))asb, 
change C m - n ) with { m + - n ) . rewrite <- ( hzrminus n ) . change { 
n - n ) with ( n + - n ). apply hzlthandplusr. assumption. rewrite ( 
hzabsvallthO a ). rewrite hzabsvalgthO . change C n - m ) with ( n + - 
m ) . rewrite hzaddinvplus . cheinge C - - m ) with ( - - m 
) °/,rng . rewrite C rngminusminus ) . rewrite hzpluscomm . apply 
idpath. apply b. destruct C hzgehchoice nmr) as [h I k]. assert 
C hzlth (n-m) ) as a. change ( n - m ) with ( n + - m ) . 
rewrite <- ( hzrminus m ) . change C m - m ) with ( m + - m ) . apply 
hzlthandplusr. assumption, assert C hzlth (m-n) 0) asb. change 
C m - n ) with C ra + - n ) . rewrite <- ( hzrminus n ) . apply 
hzlthandplusr. apply h. rewrite ( hzabsvallthO b ), rewrite C 
hzabsvalgthO ) . change ( (n+-m) ~>- (m+-n) ), rewrite 
hzaddinvplus. change C - - n ) with ( - - n )Xrng. rewrite 
rngminusminus. rewrite hzpluscomm. apply idpath. apply a. rewrite 
k. apply idpath. Defined. 

Lemma hzabsvalneqO ( n : hz ) C p : hzneq On): hzlth C nattohz ( 
hzabsval n ) ). Proof. intros. destruct C hzneqchoice n p ) as [ 
left I right ] . rewrite hzabsvallthO. apply hzlthOeindminus , apply 
left, apply left, rewrite hzabsvalgthO. assumption, apply right. 
Defined. 



Definition hzrdistr ( a b c : hz ) 
b * c ) ) : = mgrdistr hz a b c . 

Definition hzldistr ( a b c : hz ) 
c * b ) ) := mgldistr hz a b c. 



:(a+b)*c~>(Ca*c)+C 
:c*(a+b)~>{Cc*a)+C 



Lemma hzabsvalandl : hzabsval 1 ~> l5inat . Proof . apply ( isinclisinj 
isinclnattohz ). rewrite hzabsvalgthO. rewrite nattohzandl. apply 
idpath. rewrite <- C hzpluslO 1). apply C hzlthnsn ). Defined. 

Lemma hzabsvalandplusnonneg ( n m : hz ) ( p : hzleh On) ( q : hzleh 
m ) : hzabsval (n + m) ~> C C hzabsval n ) + ( hzabsval m ) )Vtnat. 
Proof. intros. assert ( hzleh (n+m) ) asr. rewrite <- ( 
hzrminus n ) , change C n - n ) with ( n + - n ) . apply 
hzlehandplusl. apply ( istranshzleh _ _ ). apply 
hzgehOandminus . apply p. assumption. apply C isinclisinj 
isinclnattohz ) . rewrite nattohzandplus . rewrite 3! 
hzabsvalgehO . apply idpath, apply q. apply p. apply r. Defined. 

Lemma hzabsvalandplusneg ( n m : hz ) C P : hzlth n ) ( q : hzlth m 
) : hzabsval (n+m)~>(C hzabsval n ) + ( hzabsval m ) )%nat. 
Proof. intros. assert C hzlth (n+m) 0) asr. rewrite <- ( 



hzrminus n ) , change C n - n ) with { n + - n ) . apply 
hzlthandplusl . apply ( istranshzlth _ _ ). assumption, apply 
hzlthOandminus . assximption. apply ( isinclisinj isinclnattohz ). 
rewrite nattohzandplus . rewrite 3 ! hzabsvallthO. rewrite 
hzaddinvplus . apply idpath.. apply q. apply p. apply r. Defined. 

Lemma hzabsvalandnattohz ( n : nat ) : hzabsval ( nattohz n ) ~> n. 
Proof, induction n, rewrite nattohzandO. rewrite hzabsvalO. apply 
idpath , rewrite nattohzandS , rewrite hzabsval andplusnonneg . rewrite 
hzabsvalandl . simpl . apply maponpaths . assumption . rewrite <- ( 
hzpluslO 1). apply hzlthtoleh. apply C hzlthnsn ). rewrite <- 
nattohzandO. apply nattohzandleh . apply natlehOn. Defined. 

Lemma hzabsvalandlth C n m : hz ) C p : hzleh On) C p' : hzlth n m ) 
: natlth ( hzabsval n ) ( hzabsval m ). Proof. intros. destruct ( 
natlthorgeh ( hzabsval n ) ( hzabsval m))as[h|k]. 
assumption, assert empty, apply C isirref Ihzlth m ). apply ( 
hzlehlthtrans _ n _ ) . rewrite <- C hzabsvalgehO ) . rewrite <- ( 
hzabsvalgehO p ). apply nattohzandleh. apply k, apply 
hzgthtogeh, apply ( hzgthgehtrans _ n _ ). apply p'- apply 
p . assumpt ion . contradi ct ion . Def ined . 

Lemma nattohzandlthinv ( n m : nat ) ( p : hzlth ( nattohz n ) 
(nattohz m ) ) : natlth n m. Proof, intros. rewrite <- ( 
hzabsvalandnattohz n } . rewrite <- ( hzabsvalandnattohz m ) . apply 
hzabsvalandlth. change with ( nattohz O'^^nat ). apply nattohzandleh. 
apply natlehOn . assumption. Defined. 



Close Scope hz_scope. 



C** * IV, Generalities on apar-tness relations *) 

Definition iscomparel { X : UUO } ( R : hrel X ) := forall x y z : X, 
R X y -> coprod (Rxz) (Rzy). 



Definition isapart { X : UUO } ( R : hrel X ) := dirprod ( isirref 1 R 
) C dirprod ( issymm R ) ( iscotrans R ) ) . 



Definition istightapart { X : UUO }■ C R : hrel X ) := dirprod ( 
isapart R ) ( forall x y : X, neg (Rxy) -> (x*'>y) ). 

Definition apart ( X : hSet ) := total2 ( fun R : hrel X => isapart R 



Definition isbinopapartl { X : hSet > ( R : apart X ) ( opp : binop X 
) := forall a b c : X, ( ( prl R ) C opp a b ) ( opp a c ) ) -> ( prl 
R ) b c. 



Definition isbinopapartr -C X : hSet } ( R : apart X ) ( opp : binop X 
) := forall a b c : X, ( prl R ) C opp b a ) C opp c a ) -> ( prl R ) 

b c. 



Definition isbinopapart -[ X : hSet } ( R : apar"t X ) ( opp : binop X ) 
:= dirprod ( isbinopapartl R opp ) ( isbinopapartr R opp ). 

Lemma deceqtoneqapart { X : UUO } ( is : isdeceq X ) : isapar"t ( neq X 
), Proof, intros, split, intros a, intro p, apply p, apply idpath. 
split, intros a b p q. apply p. apply pathsinvO. assumption. intros a 
c b p P s, apply s, destruct (isac)as [1 I r], apply 
ii2. rewrite <- 1. assumption, apply ill. assumption. Defined. 

Definition isapartdec { X : hSet } ( R : apart X ) := forall a b : X, 
coprod C ( prl R)ab) (a~>b). 

Lemma isapartdectodeceq {. X : hSet } ( R : apart X ) ( is : isapartdec 
R ) : isdeceq X. Proof, intros X R is y z. destruct C is y z ) as [ 



1 I r ]. apply ii2. intros f. apply ( ( prl ( pr2 R ) ) z) . rewrite f 
in 1 , assumption . apply iil , assumption , Defined . 

Lemma isdeceqto isapartdec ( X : hSet ) ( is : isdeceq X ) : isapartdec 
C tpair _ ( deceqtoneqapart is ) ) . Proof, intros X is a b. destruct 
(isab)as[l|r]. apply ii2. assumption, apply iil. intros 
f. apply r. assumption. Defined. 

(** * V. Apartness relations on rings *) 

Open Scope mg_scope. 

Definition acommmg := total2 C fun X : commzng => total2 C fun R : 
apart X => dirprod ( isbinopapart R ( Qopl X ) ) ( isbinopapart R ( 
Qop2 X ) ) ) ) . 

Definition acommmgpair := tpair ( P := fun X : commrng => total2 ( 
fun R : apart X => dirprod C isbinopapart R C Qopl X ) ) ( 
isbinopapart R ( Sop2 X ) ) ) ). Definition acommmgconstr : = 
acommrngpair . 

Definition acommrngto commrng : acommrng -> commrng := Qprl _ _. 
Coercion acommrngtocommmg : acommmg >-> commrng , 

Definition acommingapartrel ( X : acommrng ) := prl ( prl C pr2 X ) ). 
Notation " a # b " := C acommmgapartrel _ a b ) (at level 50 ) : 
mg_scope . 

Definition acommzTig_aadd C X : acommrng ) : isbinopapart ( prl ( pr2 X 
) ) opl := ( prl C pr2 { pr2 X ) ) ). Definition acommmg_amult C X : 
acommrng ) ; isbinopapart ( prl ( pr2 X ) ) op2 := ( pr2 ( pr2 ( pr2 X 
) ) ) . Definition acommrng_airref 1 ( X : acommrng ) : isirref 1 ( prl 
C prl ( pr2 X ) ) ) := prl ( pr2 (prl C pr2 X ) ) ). Definition 
acommrng_asymm ( X : acommrng ) : issymm ( prl C prl ( pr2 X ) ) ) := 
prl C pr2 ( pr2 ( prl C pr2 X ) ) ) ). Definition acommrng_acotrans ( 
X : acommmg ) : iscotrans ( prl ( prl ( pr2 X ) ) ) := pr2 ( pr2 ( 
pr2 C prl C pr2 X ) ) ) ). 

Definition aintdom total2 ( fun A : acommrng => dirprod C C 
rngunel2 ( X A ) ) # ) ( forall ab:A, (a#0)->(b#0) 
->C(a*b)#0))). 

Definition aintdompair := tpair ( P := fun A : acommrng => dirprod ( ( 
mgunel2 C X := A ) ) # ) ( forall ab:A, (a#0)->(b#0) 
->(Ca*b)#0))). Definition aintdomconstr := aintdompair. 

Definition prlaintdom : aintdom -> acommrng ;= 3prl _ _. Coercion 
prlaintdom : aintdom >-> acommrng. 

Definition aintdomazerosubmonoid ( A : aintdom ) : Ssubabmonoids ( 
rngmultabmonoid A ). Proof, intros. split with ( fun x : A => ( x # 
) ). split, intros a b. simpl in *. apply A. apply a. apply b. apply 
A. Defined. 

Definition isaafield ( A : acommrng ) := dirprod ( C mgunel2 ( X := A 
) ) # ) C forall X : A, x # -> multinvpair Ax). 

Definition afld := total2 ( fun A : acommrng => isaafield A ). 
Definition afldpair ( A : acomnurng ) ( is : isaafield A ) : afld := 
tpair A is . Definition prlafld : afld -> acommrng := Qprl _ _ . 
Coercion prlafld : afld >-> acommmg. 

Lemma af Idinvertibletoazero ( A : afld ) ( a : A ) ( p : multinvpair A 
a ) : a # 0, Proof. intros. destruct p as [a' p ]. assert ( a' * a 
# ) as q. change (a' * a # ). assert ( a' * a ~> a * a' ) as 
f. apply C mgcomm2 A ). assert ( a * a' "> 1 ) as g. apply 



p. rewrite f, g, apply A. assert ( a' * a # a' * ( rngunell C X ;= A 
) ) ) as q' , assert ( ( rngunell ( X := A ) ) ~> ( a' * ( rngunell ( 
X :=A) ) ) ) asf. apply pathsinvO. apply C mgmultxO A ). rewrite 
<- f. assumption, apply ( C prl ( acommmg.amult A ) ) a' 
). assumption. Defined. 

Definition af Idtoaintdom ( A : af Id ) : aintdom . Proof . intro 
. split with C prl A ) , split, apply A. intros a b p q. apply 
ai Idinvertibletoazero. apply multinvmultstable . apply A. assumption, 
apply A. assumption. Defined. 

Lemma timesazero { A : acommmg }{ab:A}Cp:a*b#0) : 
dirprod Ca#0) Cb#0). Proof. intros. split, assert C a * b # 
* b ) as h. rewrite ( rngmultOx A ). assumption, apply ( ( pr2 ( 
acommrng_amult A ) ) b ) . assumption. apply ( ( prl ( acommrng_amult 
A ) ) a ). rewrite C rogmultxO A ). assumption. Defined. 

Lemma aaminuszero { A ; acomrarng }{ab:A}Cp;a#b) ; (a-b 
) # 0. Proof. intros. rewrite <- C rngrunaxl A a ) in p. rewrite <- 
( rngrunaxl A b ) in p. assert Ca+0~>(a+Cb-b) ) )as 
f. rewrite <- ( mgrinvaxl A b ), apply idpath. rewrite f in 
p. rewrite <- ( mgmultwithminus 1 A ) in p. rewrite <- ( rngassocl A) 
in p. rewrite ( mgcomml A a ) in p. rewrite ( rngassocl A b ) in 
p. rewrite C mgmultwithminus 1 A ) in p. apply ( ( prl ( 
acommmg_aadd A))b(a-b)0). assumption. Defined. 



Lemma aminuszeroa { A : acommrng >{ab:A>Cp: (a-b)#0) ; 
a # b. Proof. intros. change with ( Qrngunell A ) in p. rewrite 
<- C mgrinvaxl A b ) in p. rewrite <- ( mgmultwithminus 1 A ) in 
p. apply ( C pr2 ( acommmg_aadd A) ) (-l*b) ab). assumption. 
Defined. 



Close Scope rng_scope. 

(** * VI. Lemmas on logic *) 



Lemma horelim ( A B : UUO ) ( P : hProp ) : dirprod C ishinh_UU A -> P 
) C ishinh_UU B -> P ) -> C hdisj A B -> P ) . Proof. intros A B P 
p. intro q. apply q. intro u. destruct u as [ u I v ]. apply C prl p 
). intro Q. auto, apply ( pr2 p ). intro Q. auto. Defined. 

Lemma stronginduction { E : nat -> UU > C p : E O'/jiat ) ( q : forall n 
: nat, natneq n OVoiat -> C C forall m : nat, natlth m n -> E m ) -> E 
n ) ) : forall n ; nat, E n. Proof. intros. destruct 
n, assumption, apply q. apply ( negpathssxO n ). induction n. intros 
m t. rewrite ( natlthltoisO m t ). assumption, intros m t. destruct 
( natlehchoice _ _ C natlthsntoleh _ _ t ) ) as [ left I right ] . 
apply IHn. assumption, apply q. rewrite right, intro f. apply C 
negpathssxO n ). assumption, intros k s. rewrite right in s. apply ( 
IHn k ) . assumption. Defined. 

Lemma setquotprpathsandR { X : UUO } { R : eqrel X ) : forall x y : X, 
setquotpr R x ~> setquotpr R y -> R x y. Proof. intros. assert ( prl 
( setquotpr R x ) y ) as i. assert ( prl ( setquotpr R y ) y ) as 
iO. unfold setquotpr. apply R. destmct XO. assumption, apply i. 
Defined. 



7.4 The file fps.v 



(* Some lemmas on decidable properties of natural numbers. *) 

Definition isdecnatprop ( P : nat -> hProp ) := forall m : nat, coprod 
C P m ) C neg C P m ) ) . 

Lemma negisdecnatprop C P : nat -> hProp ) ( is : isdecnatprop P ) : 
isdecnatprop ( fun n : nat => hneg ( P n ) ). Proof. intros P is 
n. destmct Cisn)as[l|r]. apply ii2. intro j. assert hfalse 
as X. apply j. assumption, apply x. apply iil. assumption. Defined. 

Lenmia bndexistsisdecnatprop ( P : nat -> hProp ) C is : isdecnatprop P 
) : isdecnatprop ( fun n : nat => hexists ( fun m : nat => dirprod ( 
natleh mn) (Pm) ) ). Proof. intros P is n. induction 
n. destruct C is 0°/,nat ) as [ 1 I r ] . apply iil. apply 
total2tohexists . split with O^jiat . split . apply 
isref Inatleh. assumption, apply ii2. intro j. assert hfalse as 
X. apply j. intro m. destruct m as [mm' ]. apply r. rewrite C 
natlehOtoisO m ( prl m* ) ) in ra' . apply m' , apply x. 

destruct CisCSn))as[l|r]. apply iil. apply 
total2tohexists , split with ( S n ). split, apply ( isref Inatleh { S n 
) ). assumption, destruct IHn as [ 1 ' I r' ], apply iil. apply 1'. 
intro m. destruct m as [mm' ]. apply total2tohexists , split with 
m. split, apply ( istransnatleh _ n _ ). apply m' . apply 
natlthtoleh. apply natlthnsn, apply m' . apply ii2, intro j. apply 
r* . apply j, intro m, destruct m as [mm' ]. apply 

total2tohexists , split with m, split, destruct C natlehchoice m ( S n 
) C prl m' ) ) . apply natlthsntoleh. assumption, assert empty, apply 
r. rewrite <- i. apply m' . contradiction, apply m' . Defined. 

Lemma isdecisbndqdec C P : nat -> hProp ) ( is : isdecnatprop P ) C n 
: nat ) : coprod ( forall m : nat, natleh m n -> P m ) C hexists C fun 
m ; nat dirprod ( natleh m n ) ( neg ( P m ) ) ) ) . Proof . intros 
P is n, destruct C bndexistsisdecnatprop _ C negisdecnatprop P is ) n 
) as [ 1 1 r ] , apply ii2. assumption, apply iil. intros m j. destmct 
C is m ) as [ 1' I r' ] . assumption, assert hfalse as x. apply 
r. apply total2tohexists . split with 

m. split . assumption, assumption, contradiction. Defined. 

Lemma leastelementprinciple ( n : nat ) ( P : nat -> hProp ) ( is : 
isdecnatprop P ) : P n -> hexists ( fun k : nat => dirprod ( P k ) ( 
forall m : nat, natlth m k -> neg ( P m ) ) ). Proof, intro 
n. induction n. intros P is u, apply total2tohexists . split with 
0°/,nat . split , assumption, intros m i , assert empty, apply C 
negnatgthOn mi), contradiction, intros P is u, destruct ( is O'^^nat 
) as [ 1 I r ] . apply total2tohexists . split with O^jiat. split, 
assumption, intros m i. assert empty, apply C negnatgthOn m i 
). contradiction, set C P' := fun m : nat => P C S m ) ). assert C 
forall m : nat, coprod ( P* m ) C neg ( P' ra ) ) ) as is', intros 
m. unfold P', apply (is C S m ) ), set ( c IHn P' is' u ). apply 
c. intros k. destruct k as [ k v ]. destruct v as [ vO vl ] . apply 
total2tohexists . split with ( S k ). split, assumption, intros 
m. destmct m. intros i. assumption, intros i. apply vl. apply i. 
Defined. 



(** END OF FILE *) 
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C** Settings *) 

Add Rec LoadPath "../Generalities". Add Rec LoadPath " . ./hlevell" . 

Add Rec LoadPath " . . /hlevel2" . Add Rec LoadPath 

" . ./Proof_of_Extensionality" . Add Rec LoadPath "../Algebra". 

Unset Automatic Introduction. (** This line has to be removed for the 
file to compile with Coq8.2 *) 

(** Imports *) 

Require Export lemmas . 

(** ** I. Summation in a commutative ring *) 
Open Scope rng_scope. 

Definition natsummationO { R : commrng } C upper : nat ) ( f : nat -> 
R ) : R. Proof, intro R. intro upper, induction upper, intros. exact 
{ f 0°/«nat ) . intros . exact ( ( IHupper f + C f ( S upper ) ) ) ) . 
Defined. 

Lemma natsummationpaths -[ R : commmg } { upper upper* : nat }- ( u : 
upper ~> upper' ) ( f : nat -> R ) : natsummationO upper f ~> 
natsummationO upper' f . Proof . intros . destruct u. auto . Defined. 

Lemma natsummationpathsupperf ixed { R : commrng } ■[ upper : nat } ( f 
f : nat -> R ) C p : forall x : nat, natleh x upper -> f x ~> f x ) 
: natsummationO upper f ~> natsummationO upper f*. Proof. intros R 
upper, induction upper, intros f f p. simpl. apply p. apply 
isref Inatleh. intros. simpl. rewrite C IHupper f f ). rewrite ( p ( 
S upper ) ). apply idpath. apply isref Inatleh. intros x p' , apply 
p. apply ( istransnatleh _ upper ). assumption, apply 
natlthtoleh. apply natlthnsn. Defined. 

(* Here we consider summation of functions which are, in a fixed 
interval, for all but either the first or last value. *) 

Lemma natsummationaeObottom {, R : commrng } { f : nat -> R } C upper : 
nat ) ( p : forall x : nat, natlth x -> f x ~> ) : natsummationO 
upper f "> C f OiCnat ). Proof, intros R f upper, induction 
upper, auto, intro p. simpl. rewrite C IHupper ). rewrite C p C S 
upper ) ). rewrite ( rngrunaixl R ). apply idpath. apply { 
natlehlthtrans _ upper _ ) . apply natlehOn. apply 
natlthnsn . assumpt ion . Def ined . 

Lemma natsummationaeOtop { R : conmimg }■ { f : nat -> R } C upper : 
nat ) C p : forall x : nat, natlth x upper -> f x ~> ) : 
natsummationO upper f "> ( f upper ). Proof, intros R f 
upper, induction upper, auto, intro p. assert ( natsummationO upper f 
~> C natsummationO ( R := R ) upper ( fun x ; nat => ) ) ) as g. 
apply natsummationpathsupperf ixed. intros m q. apply p. exact ( 
natlehlthtrans m upper ( S upper ) q ( natlthnsn upper ) ) . 
simpl. rewrite g. assert C natsummationO C R := R ) upper C fun _ : 
nat => ) ~> ) as g' . set C g' ' := fun x : nat => mgunell ( X := R 
) ). assert C forall x : nat, natlth x -> g' ' x ~> ) as qO. intro 
k. intro pp. auto, exact C natsummationaeObottom upper qO ). rewrite 
g' . rewrite ( rnglunaxl R ). apply idpath. Defined. 

Lemma natsummationshif tO { R : conmimg } ( upper : nat ) ( f : nat -> 



R ) : natsummationO ( S upper ) f ~> C natsummationO upper ( fun x ; 
nat =>f (Sx) )+f 0%nat ). Proof. intros R upper, induction 
upper, intros f. simpl. apply R. intros. change C natsummationO C S 
upper )f+f{S{S upper ))"■>{ natsummationO upper ( fun x : nat 
=>fCSx))+fCSCS upper ) ) + f 07,nat ) ) . rewrite 
IHupper. rewrite 2! ( rngassocl R ). rewrite ( rngcomml R ( f 0%nat ) 
_ ) . apply idpath. Defined. 

Lemma natsummationshif t { R : commrng > ( upper : nat ) ( f : nat -> R 
) { i : nat > ( p : natleh i upper ) : natsummationO C S upper ) f ~> 
C natsummationO upper C funcomp ( natcoface i) f)+fi). Proof, 
intros R upper, induction upper, intros f i p. destruct i. unfold 
funcomp. apply R. assert empty, exact ( negnatlehsnO i p 
). contradiction. intros f i p. destruct i. apply natsummationshif tO . 
destruct ( natlehchoice (Si) C S upper )p)as[h|k], change 
C natsummationO C S upper )f+fCSCS upper ) ) ~> ( natsummationO 
C S upper ) C funcomp ( natcoface CSi))f)+fCSi)) 
). rewrite ( IHupper f (Si) ). simpl. unfold funcomp at 3. unfold 
natcoface at 3. rewrite 2! ( rngassocl R ). rewrite ( rngcomml R _ ( 
f (Si) ) ). simpl. rewrite ( natgehimplnatgtbf also i upper ), apply 
idpath. apply p. apply natlthsntoleh. assumption. simpl. assert C 
natsummationO upper ( funcomp ( natcoface (Si))f)~> 
natsummationO upper f ) as h. apply 

natsummationpathsupperf ixed. intros m q. unfold funcomp. unfold 
natcoface. assert ( natlth m ( S i ) ) as q' . apply ( natlehlthtrans _ 
upper ). assumption, rewrite k. apply natlthnsn. unfold natlth in q' . 
rewrite q' . apply idpath. rewrite <- h. unfold funcomp, natcoface at 
3. simpl. rewrite ( natgehimplnatgtbf alse i upper ). rewrite 2! ( 
rngassocl R ) . rewrite ( rngcomml R ( f ( S C S upper ) ) ) ) . rewrite 
k. apply idpath. apply p. Defined. 

Lemma natsummationplusdistr { R : commrng } ( upper : nat ) ( f g ; 
nat -> R ) : natsummationO upper ( fun x : nat =>fx+gx) ~> ( ( 
natsummationO upper f ) -*- ( natsummationO upper g ) ). Proof, intros 
R upper, induction upper, auto, intros f g. simpl. rewrite <- { 
rngassocl R _ ( natsummationO upper g ) _ ) . rewrite ( rngassocl R ( 
natsummationO upper f ) ) . rewrite ( rngcomml R _ C natsummationO 
upper g ) ) . rewrite <- ( rngassocl R ( natsummationO upper f ) ) . 
rewrite <- ( IHupper f g ). rewrite ( rngassocl R ). apply idpath. 
Defined. 



Lemma natsummationtimesdistr { R : commrng } ( upper : nat ) C f : nat 
->R) (k:R) :k*( natsummationO upper f ) *"> ( natsummationO 
upper ( fun x : nat => k * f x ) ). Proof. intros R upper, induction 
upper . auto . intros f k . simpl . rewrite <- C IHupper ) . rewrite <- C 
rngldistr R ). apply idpath. Defined. 



Lemma natsummationtimesdistl { R : commrng } ( upper : nat ) C f : nat 
->R) (k;R) : ( natsummationO upper f ) * k ~> ( natsummationO 
upper ( fun x : nat f x * k ) ). Proof. intros R upper, induction 
upper, auto . intros f k. simpl . rewrite <- IHupper . rewrite ( 
rngrdistr R ). apply idpath. Defined. 



Lemma nat summat ions swapminus { R : commrng } { upper n : nat } ( f : 
nat -> R ) ( q : natleh n upper ) : natsummationO ( S ( minus upper n 
) ) f ~> natsummationO ( minus ( S upper ) n ) f. Proof. intros R 
upper, induction upper, intros n f q. destruct n. auto, assert 
empty, exact ( negnatlehsnO n q ). contradiction. intros n f 
q. destruct n. auto, change ( natsummationO ( S C minus upper n ) ) f 
"> natsummationO C minus C S upper ) n ) f ). apply IHupper. apply q. 
Defined. 



(** The following lemma asserts that 

$\sum"-[n>_{k=0}\sum"{k}_{l=0}f (l,k-l)=\sum"-[n}_-{:k=0}\sum"-[n-k}_{l=0}f (k,l)$ 
*) 



Lemma natsummationswap -[ R : commrng > ( upper : nat ) C f : nat -> 
nat -> R ) : natsummationO upper ( fun i : nat => nat summat ionO i ( 
fun j : nat => f j C minus i j ) ) ) ~> C natsximmationO upper ( fun k 
: nat => natsummationO C minus upper k ) C fun 1 : nat => f k 1 ) ) ) . 
Proof. intros R upper, induction upper, auto. 

intros f. change ( natsummationO upper (fun i : nat => natsummationO 
i (fun j : nat => f j ( minus i j))) + natsummationO ( S upper ) ( 
fun j ; nat => f j ( minus ( S upper ) j ) ) ~> C natsummationO 
upper (fun k : nat => natsummationO CS upper - k) (fun 1 : nat => f 
k 1)) + natsummationO C minus C S upper ) ( S upper ) ) C fun 1 : 
nat => f ( S upper ) 1 ) ) ) . change ( natsummationO upper (fun i : 
nat => natsummationO i (fun j : nat => f j ( minus i j))) + ( 
natsummationO upper ( fun j : nat f j C minus ( S upper ) j ) ) + 
f C S upper ) ( minus ( S upper ) ( S upper ) ) ) ~> C natsummationO 
upper (fun k : nat => natsinranationO (S upper - k) (fun 1 : nat => f 
k D) + natsummationO ( minus ( S upper ) ( S upper ) ) C fun 1 : 
nat => f C S upper )!))). 

assert ( (natsummationO upper (fun k : nat => natsummationO ( S ( 
minus upper k ) ) (fun 1 : nat f k 1)) ) "> (natsummationO upper 
(fim k : nat => natsummationO (minus ( S upper ) k) (fun 1 : nat => 
f k 1)) ) ) as A. apply natsummationpathsupperf ixed. intros n 
q. apply natsummationsswapminus. ezact q. rewrite <- A. change C 
fun k : nat => natsummationO (S ( minus upper k)) (fun 1 : nat => f 
k 1) ) with ( fun k ; nat => natsummationO ( minus upper k ) ( fun 1 
: nat =>fkl)+fk(S( minus upper k ) ) ) . rewrite ( 
natsummationplusdistr upper _ ( fun k : nat => f k ( S ( minus upper 
k ) ) ) ). rewrite IHupper. rewrite minusnnO. rewrite ( mgas&ocl 
R) . assert ( natsummationO upper ( fun j : nat => f j ( minus ( S 
upper ) j ) ) ~> natsummationO upper ( fun k ; nat => f k ( S ( 
minus upper k ) ) ) ) as g. apply 

natsummationpathsupperf ixed. intros m q. rewrite pathssminus, apply 
idpath. apply ( natlehlthtrans _ upper ). assumption, apply 
natlthnsn . rewrite g . apply idpath . Def ined . 

(** * II. Reindexing along functions i : nat -> nat which are 
automorphisms of the interval of summation. *) 

Definition isnattruncauto ( upper : nat ) ( i : nat -> nat ) := 
dirprod ( forall x : nat, natleh x upper -> total2 ( fun y : nat => 
dirprod ( natleh y upper ) ( dirprod C i y "> x ) ( forall z : nat, 
natleh z upper -> i z "> x -> y ~> z ) ) ) ) ( forall x : nat, natleh 
X upper -> natleh ( i x ) upper ) . 

Lemma nattruncautoisinj { upper : nat } ■[ i : nat -> nat } ( p : 
isnattruncauto upper i ) { n m : nat } ( n' : natleh n upper ) ( m' : 
natleh m upper ) : i n ~> i m -> n ~> m. Proof. intros upper i p n m 
n' m' h. assert ( natleh ( i m ) upper ) as q. apply 

p. assumption, set ( x prl p ( 1 m ) q ). set ( v := prl x ), set ( 
w := prl ( pr2 x ) ). set ( y := prl ( pr2 ( pr2 x ) ) ), change ( 
prl X ) with V in w, y. assert ( v ~> n ) as a. apply ( pr2 x 
). assumption, assumption, rewrite <- a. apply ( pr2 x 
). assumption, apply idpath. Defined. 

Definition nattruncautopre image ■[ upper : nat } { i : nat -> nat } C p 
: isnattruncauto upper i ) { n : nat } ( n' : natleh n upper ) : nat 
:= prl ( prl p n n' ) . 

Definition nattruncautopre imagepath { upper : nat } { i : nat -> nat } 
( p : isnattruncauto upper i ) ■( n : nat } ( n* : natleh n upper ) : i 
( nattruncautopre image p n* ) *"> n := ( prl ( pr2 ( pr2 ( prl p n n* ) 

) ) ). 

Definition nattruncautopre imageineq { upper : nat } { i : nat -> nat } 
( p : isnattruncauto upper i ) { n : nat } ( n' : natleh n upper ) : 



natleh ( nattruncautopre image p n' ) upper := ( C prl ( pr2 ( prl p n 

n' ) ) ) ). 

Definition nattruncautopreimagecEinon { upper : nat } { i : nat -> nat 
]■ ( p : isnattrimcauto upper i ) { n : nat > ( n' ; natleh n upper ) { 
m : nat } ( m' ; natleh m upper ) (q: im~>n) : 

nattruncautopre image p n' ~> m := ( pr2 ( pr2 C pr2 ( prl p n n' ) ) ) 
) m m' q. 

Definition nattruncautoinv { upper : nat } { i : nat -> nat } ( p : 
isnattruncauto upper i ) : nat -> nat. Proof, intros upper i p 
n. destruct ( natgthorleh n upper ) as [ 1 I r ] . exact n. exact ( 
nattruncautopreimage p r ). Defined, 

Lemma nattruncautoinv isnattruncauto { upper : nat } ■[ i : nat -> nat } 
( p : isnattruncauto upper i ) : isnattruncauto upper ( 
nattruncautoinv p ). Proof. intros. split, intros n n' . split with ( 
in), split, apply p. assumption, split, unfold 

nattruncautoinv, destruct ( natgthorleh (in) upper ) as [ 1 I r 
] . assert empty, apply ( isirref Inatlth (in) ) . apply ( 
natlehlthtrans _ upper ) , apply 

p . assumption, assumption, contradiction, apply ( nattruncautoisinj p 
) . apply ( nattruncautopreimageineq ) . assumption, apply ( 
nattruncautopre imagepath p r ) , intros m x v. unfold nattruncautoinv 
in V. destruct ( natgthorleh m upper ) as [1 I r ]. assert 
empty, apply ( isirref Inatlth upper ), apply C natlthlehtrans _ m 
) . assumption, assumption, contradiction, rewrite <- v, apply ( 
nattruncautopre imagepath p r ). intros x X. unfold 
nattruncautoinv. destruct ( natgthorleh x upper ) as [ 1 I r 
]. assumption, apply ( nattruncautopreimageineq p r ). Defined. 

Definition truncnattruncauto { upper : nat } { i : nat -> nat } ( p : 
isnattruncauto ( S upper ) i ) : nat -> nat. Proof. intros upper i p 
n. destruct ( natlthorgeh (in) ( S upper ) ) as [ 1 I r ] . exact 
(in), destruct ( natgehchoice __r)as[a|b]. exact (in), 
destruct ( isdeceqnat n ( S upper ) ) as [ h I k ] . exact (in), 
exact ( i ( S upper ) ) . Defined. 

Lemma truncnattruncautobound { upper : nat > ( i : nat -> nat ) ( p : 
isnattruncauto ( S upper ) i ) ( n : nat ) ( q : natleh n upper ) : 
natleh ( truncnattruncauto p n ) upper. Proof. intros. unfold 
truncnattruncauto. destruct C natlthorgeh (in) ( S upper) ) as C 1 
I r ] . apply natlthsntoleh. assumption, destruct ( natgehchoice (in 
) C S upper ) ) as [ 1' I r' ] . assert empty, apply ( isirref Inatlth ( 
in)), apply ( natlehlthtrans _ ( S upper ) ). apply p. apply 
natlthtoleh. apply ( natlehlthtrans _ upper ). assumption, apply 
natlthnsn. assumption, contradiction, destruct ( isdeceqnat n ( S 
upper ) ) as [1*' I r* * ] . assert empty, apply ( isirref Inatlth upper 
). apply ( natlthlehtrans _ ( S upper ) ). apply natlthnsn, rewrite <- 
1' ' . assumption, contradiction, assert ( natleh ( i ( S upper ) ) ( S 
upper ) ) as aux. apply p. apply isref Inatleh. destruct ( natlehchoice 
_ _ aux ) as [ 1''' I r' ' ' ] . apply natlthsntoleh. assumption, assert 
empty, apply r''. apply ( nattruncautoisinj p ). apply 
natlthtoleh. apply ( natlehlthtrans _ upper ). assumption, apply 
natlthnsn. apply isref Inatleh. rewrite r'. rewrite r'''. apply 
idpath . contradict ion . Def ined . 

Lemma truncnattruncautoisinj { upper : nat } { i : nat -> nat } ( p : 
isnattruncauto ( S upper ) i ) ■[ n m : nat > ( n' : natleh n upper ) ( 
m' : natleh m upper ) : truncnattruncauto p n *"> truncnattruncauto p m 
-> n ~> m. Proof. intros upper i p n m q r s. apply ( 
nattruncautoisinj p ). apply natlthtoleh. apply ( natlehlthtrans _ 
upper ). assumption, apply natlthnsn. apply natlthtoleh. apply ( 
natlehlthtrans _ upper ) . assumption, apply natlthnsn. unfold 
truncnattruncauto in s. destruct ( natlthorgeh (in) ( S upper ) ) 
as [ aO I al ] . destruct ( natlthorgeh ( i m ) ( S upper ) ) as [ bO I 



bl ] , assumption, assert empty, assert ( i m "> S upper ) as fO. 
destruct C natgeh choice ( i m ) ( S upper ) bl ) as [1 I 1' ] . assert 
empty, apply ( isirref Inatlth ( S upper ) ). apply ( natlehlthtrans _ 
( in) ) . rewrite 

B . assumption . assumption . contradiction . assumption . destruct ( 
natgehchoice ( i m ) ( S upper ) bl ) as [ aOO I alO ] . apply C 
isirref Inatgth C S upper ) ). rewrite fO in aOO, assumption, destruct 
C isdeceqnat m ( S upper ) ) as [ aOOO I alOO ] , rewrite s in 
aO, rewrite fO in aO, apply C isirref Inatlth C S upper ) 
). assumption. assert Cim~>n)asfl. apply ( nattruncautoisinj p 
). rewrite fO. apply isreflnatleh. apply natlthtoleh. apply ( 
natlehlthtrans _ upper ). assumption, apply natlthnsn. rewrite fO. 
rewrite s , apply idpath, apply ( isirref Inatlth upper ) . apply C 
natlthlehtrans _ n ). rewrite <- fl, fO. apply 

natlthnsn. assumption, contradiction. destruct ( natgehchoice (in) 
( S upper ) al ) as [ aOO I aOl ] . assert empty, apply ( 
isirref Inatlth C S upper ) ) . apply ( natlthlehtrans _ ( i n ) 
), assumption, apply C p ). apply natlthtoleh. apply ( natlehlthtrans 
_ upper ). assumption, apply natlthnsn. contradiction, destruct ( 
natlthorgeh ( i m ) ( S upper ) ) as [ bO I bl ] . destruct ( 
isdeceqnat n ( S upper ) ) as [ aOOO I aOOl ] . assumption, assert C S 
upper "> m ) as fO. apply ( nattruncautoisinj p ). apply 
isreflnatleh. apply natlthtoleh. apply ( natlehlthtrans _ upper 
) . assumption, apply natlthnsn. assumption, assert empty, apply 
aOOl. rewrite fO. assert empty, apply ( isirref Inatlth ( S upper ) 
), apply C natlehlthtrans _ upper ). rewrite fO. assumption, apply 
natlthnsn, contradiction, contradiction, destruct ( natgehchoice ( i 
m ) C S upper ) bl ) as [ bOO I bOl ] . assert empty, apply ( 
isirref Inatlth C i m ) ) . apply C natlehlthtrans _ ( S upper ) 
). apply p. apply ( natlthtoleh ). apply C natlehlthtrans _ upper 
) . assumption, apply natlthnsn. assumption, contradiction, rewrite 
bOl. rewrite aOl. apply idpath. Defined. 

Lemma truncnattruncautoisauto {. upper : nat > { i : nat -> nat } ( p : 
isnattruncauto C S upper ) i ) : isnattruncauto upper ( 
trimcnatt rune auto p ), Proof. intros . split, intros n q, assert ( 
natleh n C S upper ) ) as q' . apply natlthtoleh. apply C 
natlehlthtrans _ upper ), assumption, apply natlthnsn. destruct ( 
isdeceqnat ( nattruncautopre image p q' ) ( S upper ) ) as [ iO I il 
] . split with ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) 
). split, assert ( natleh ( nattruncautopreimage p ( isreflnatleh ( S 
upper ) ) ) C S upper ) ) as aux. apply 

nattruncautopreimageineq. destruct ( natlehchoice _ _ aux ) as [ 1 I r 

] . apply natlthsntoleh. assumption, assert C n ~> S upper ) as 

fO. rewrite <- ( nattruncautopreimagepath p q' ). rewrite iO. rewrite 

<- r. rewrite ( nattruncautopreimagepath p ( isreflnatleh ( S upper) ) 

). rewrite r. apply idpath. assert empty, apply C isirref Inatlth C S 

upper ) ) . apply ( natlehlthtrans _ upper ) . rewrite <- 

fO . assumption, apply natlthnsn. contradiction. 

split, apply { nattruncautoisinj p ). apply natlthtoleh. apply ( 
natlehlthtrans _ upper ) . apply truncnattruncautobound . destruct ( 
natlehchoice _ _ ( nattruncautopreimageineq p ( isreflnatleh ( S 
upper ) ) ) ) as [ 1 I r] . apply natlthsntoleh. assumption. assert 
empty, assert ( S upper ~> n ) as fO. rewrite <- ( 
nattruncautopreimagepath p ( isreflnatleh ( S upper ) ) ) . rewrite 
r. rewrite <- iO. rewrite ( nattruncautopreimagepath p q' ) . apply 
idpath. apply ( isirref Inatlth ( S upper ) ). apply C natlehlthtrans 
_ upper ). rewrite fO. assumption, apply 

natlthnsn. contradiction, apply natlthnsn. assumption, unfold 
truncnattruncauto . destruct ( isdeceqnat ( nattruncautopreimage p ( 
isreflnatleh ( S upper ))))as[l|r]. assert empty, assert C 
S upper ~> n ) as fO. rewrite <- C nattruncautopreimagepath p C 
isreflnatleh ( S upper ) ) ) . rewrite 1. rewrite <- iO. rewrite ( 
nattruncautopreimagepath p q' ) . apply idpath. apply ( 
isirref Inatlth ( S upper ) ) . apply ( natlehlthtrans _ upper 



) . rewrite f . assumption, apply natlthnsn. contradiction . destruct 
C natlthorgeh ( i C nattruncautopreimage p C isreflnatleh ( S upper 
) ) ) ) ( S upper ) ) as [ 1' | r' ] . assert empty, apply C 
isirref Inatlth C S upper ) ) . rewrite ( nattruncautopreimagepath p 
) in 1'. assumption, contradiction, destruct C natgehchoice _ _ r* ) 
as [1'' I r' ' ]. assert empty, apply ( isirref Inatlth C S upper ) ) 
. rewrite C nattruncautopreimagepath p ) in 
1* ' . assumption, contradiction. rewrite <- iO. rewrite ( 
nattruncautopreimagepath p q' ). apply idpath. intros x X y. apply 
( nattruncautoisinj p ) . apply nattruncautopreimageineq. apply 
natlthtoleh. apply C natlehlthtrans _ upper ). assumption, apply 
natlthnsn. unfold truncnattruncauto in y. destruct ( natlthorgeh ( 
i X ) ( S upper ) ) as [ 1 I r ] . assert ( S upper ~> x ) as 
fO. apply C nattruncautoisinj p ). apply isreflnatleh. apply 
natlthtoleh. apply ( natlehlthtrans _ upper ). assumption, apply 
natlthnsn. rewrite <- iO. rewrite y. rewrite C 

nattruncautopreimagepath p q* ) . apply idpath. assert empty, apply ( 

isirref Inatlth C S upper ) ) . apply ( natlehlthtrans _ upper 

). rewrite fO. assumption, apply natlthnsn. contradiction, destruct 

( isdeceqnat x ( S upper ) ) as [ 1' I r' ] , assert empty, apply C 

isirref Inatlth ( S upper ) ) . apply ( natlehlthtrans _ upper 

). rewrite <- 1', assumption, apply 

natlthnsn. contradiction, destruct ( natgehchoice _ _ r ) as [ 1'' I 
r** ]. assert empty, apply ( isirref Inatlth n ). apply C 
natlehlthtrans _ ( S upper ) ) . assumption, rewrite <- 
y. assumption, contradiction, rewrite ( nattruncautopreimagepath p 
). rewrite r'' . apply idpath. split with ( nattruncautopreimage p 
q' ). split, destruct ( natlehchoice _ _ C nattruncautopreimageineq 
pq'))as[l|r]. apply natlthsntoleh. assumption, assert 
empty, apply il . assumption, contradiction. split . unfold 
truncnattruncauto . destruct ( natlthorgeh ( i ( 
nattruncautopreimage p q' ) ) C S upper ) ) as [ 1 I r ] . apply 
nattruncautopreimagepath. destruct ( natgehchoice _ _ r ) as [ 1' I 
r' ] . apply nattruncautopreimagepath. assert empty, apply C 
isirref Inatlth C S upper ) ) . apply C natlehlthtrans _ upper 
). rewrite <- r' . rewrite C nattruncautopreimagepath p q' 
) . assumption, apply natlthnsn. contradiction. 

intros x X y. apply ( nattruncautoisinj p ). apply C prl p ). apply 
natlthtoleh. apply ( natlehlthtrans _ upper ). assumption, apply 
natlthnsn. rewrite ( nattruncautopreimagepath p q' ) . unfold 
truncnattruncauto in y. destruct ( natlthorgeh ( i x ) C S upper ) ) 
as [1 I r ] . rewrite y. apply idpath. destruct ( isdeceqnat x ( S 
upper ) ) as [ 1' I r' ], assert empty, apply ( isirref Inatlth C S 
upper ) ) . apply ( natlehlthtrans _ upper ) . rewrite <- 
1' . assumption, apply natlthnsn. contradiction, destruct ( 
natgehchoice _ _ r ). rewrite y. apply idpath. assert empty, apply 
il. apply C nattruncautoisinj p ). apply C nattruncautopreimageineq 
p ). apply isreflnatleh. rewrite ( nattruncautopreimagepath p q' 
) . rewrite y . apply idpath. contradiction. apply 
truncnattruncautobound . Def ined . 

Definition truncnattruncauto inv { upper : nat } { i : nat -> nat } ( p 
: isnattruncauto C S upper ) i ) : nat -> nat := nattruncautoinv ( 
truncnattruncautoisauto p ) . 

Lemma precompwithnatcof aceisauto { upper : nat } ( i : nat -> nat ) ( 
p ; isnattruncauto ( S upper ) i ) ( bound : natlth ( 
nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) ) : 
isnattruncauto upper (funcomp C natcoface C nattruncautopreimage p ( 
isreflnatleh C S upper ) ) ) ) i ). Proof. intros. set C v := 
nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) . change ( 
nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) with v in 
bound, unfold isnattruncauto. split, intros m q. unfold 
funcomp. assert ( natleh m C S upper ) ) as aaa. apply 
natlthtoleh. apply natlehlthtrans with C m := upper 



), assumption, exact C natlthnsn upper ). set ( m' := 
nattruncautopre image p aaa ) . destruct ( natlthorgeh m' v ) as [ 1 I 
r ]. C* CASE m' < v *) split with m' . split, apply natlthsntoleh. 
apply C natlthlehtrans _ v ) . assumption, apply ( 
nattruncautopre image ineq p _ ). split, unfold natcoface. rewrite 
1. apply ( nattnmcautopreimagepath p aaa ). intros n j w. assert ( 
natcoface v n ~> m' ) as fO, apply pathsinvO. apply C 
nattriincautopreimagecaiion p aaa ) . apply 

natcof aceleh , assumption , assumption . rewrite <- f . destruct ( 
natgthorleh vn)as [1' |r']. unfold natcoface. rewrite 1'. apply 
idpath. assert empty, apply C isirref Inatlth v ). apply C 
natlehlthtrans _ n ) . assumption, apply C istransnatlth _ C S n ) 
), apply natlthnsn. unfold natcoface in fO. rewrite ( 
natgehimplnatgtbf alse v n r' ) in fO. rewrite 
fO. assumption, contradiction. (* CASE v <= m' *) set ( j := 
nattruncautopre imagepath p aaa ) . change ( nattruncautopre image p aaa 
) with m' in j . set Cm'* ;= minus m' 1 ) . assert ( natleh m' ' upper 
) as aO. destruct C natlthorgeh Om' ) as [h 1 h' ]. rewrite <- ( 
minussnl upper ). apply minuslleh, assumption. apply C natlehlthtrans 

upper ). apply natlehOn. apply natlthnsn. apply ( 
nattruncautopreimageineq ). destruct ( natgehchoice m' h' ) as [ k I 
k' ]. assert empty, apply ( negnatgthOn m' k ) . contradiction, unfold 
m' ' . rewrite <- k' . apply natlehOn. destruct ( natgehchoice m' v r ) 
as [ 1* I r' ] . assert C natleh v m* * ) as a2. apply 
natlthsntoleh. unfold m''. rewrite pathssminus. rewrite 
minussnl, assumption, destruct ( natlehchoice m' C natlehOn m' ) ) 
as [ k I k' ] . assumption, assert empty, apply ( negnatgthOn v 
). rewrite k' . assumption, contradiction. assert ( i ( natcoface v 
m' ' ) ~> m ) as al. unfold natcoface. rewrite ( natgehimplnatgtbf alse 

V m' ' a2 ) . unfold m' ' . rewrite pathssminus. rewrite 

minussnl, assumption, destruct ( natlehchoice m' C natlehOn m' ) ) 

as [ k I k' ] . assumption, assert empty, apply ( negnatgthOn v 

), rewrite k* . assumption, contradiction. split with 

m" . split, assumption, split, assumption, intros n s t. assert ( 

natcoface v n ~> natcoface v m* * ) as g. assert C natcoface v n "> m' 

) as gO. apply pathsinvO. apply ( nattruncautopre image canon p aaa 

). apply natcof aceleh. assumption, assumption, assert ( natcoface v 

m' ' ~> m' ) as gl . unfold m' . unfold nattruncautopreimage . apply 

pathsinvO, apply C nattruncautopreimagecanon p aaa ). apply 

natcof aceleh, assumption, assumption, rewrite gO , gl . apply idpath. 

change ( idfun _ m' ' ~> idfun _ n ). rewrite <- ( 

natcof aceretractisretract v ). unfold funcomp. rewrite g. apply 

idpath. assert empty, apply C isirref Inatlth ( S upper ) ). apply ( 

natlehlthtrans _ upper ). assert ( S upper ~> m ) as g. rewrite <- C 

nattruncautopreimagepath p ( isreflnatleh ( S upper ) ) ) . change ( i 

V ~> m ) . rewrite <- j. rewrite r' . apply idpath. rewrite 
g. assumption, apply natlthnsn. contradiction. 

intros x X. unfold funcomp. assert ( natleh ( i ( natcoface v x 
) ) { S upper ) ) as aO, apply p. apply 

natcof aceleh. assumption. destruct { natlehchoice _ _ aO ) as [ 
1 I r ]. apply natlthsntoleh. assumption, assert C v "> 
natcoface v z ) as g. unfold v. apply ( 

nattruncautopreimagecanon p ( isreflnatleh ( S upper ) ) 

). unfold natcoface. destruct C natgthorleh v z ) as [alb 

] . unfold V in a. rewrite a. apply natlthtoleh. apply C 

natlehlthtrans _ upper ). assumption, apply natlthnsn, unfold v 

in b. rewrite ( natgehimplnatgtbf alse _ x b ). assumption. 

assumption, assert empty, destruct ( natgthorleh v x ) as [ a I 

b ]. unfold natcoface in g. rewrite a in g. apply ( 

isirref Inatlth x ). rewrite g in a. assumption, unfold natcoface 

in g. rewrite ( natgehimplnatgtbf alse v x b ) in g. apply C 

isirref Inatlth x ) , apply ( natlthlehtrans _ ( S x ) ) . apply 

natlthnsn . rewrite <- g . assumption . contradiction. Defined . 

Lemma nattruncautocompstable { R : commmg } { upper : nat } ( i j : 



nat -> nat ) ( p : isnattruncauto upper i ) C p' : isnattruncauto 
upper j ) : isnattruncauto upper ( fimcomp j i ) . Proof, 
intros. split, intros n n' . split with C nattruncautopreimage p* C 
nattruncautopreimageineq p n* ) ). split, apply C 
nattruncautopreimageineq p' ). split, unfold funcomp, rewrite ( 
nattruncautopreimagepath p* _ ) . rewrite C nattruncautopreimagepath p 
_ ). apply idpath. intros x X y. unfold funcomp in y. apply ( 
nattruncautoisinj p' ) . apply 

nattruncautopreimageineq. assumption, apply C nattruncautoisinj p 
) . apply p' . apply nattruncautopreimageineq. apply 
p' . assumption, rewrite ( nattruncautopreimagepath p' ) . rewrite C 
nattruncautopreimagepath p ). rewrite y. apply idpath. intros x 
X. unfold funcomp, apply p. apply p' . assumption. Defined. 

Definition nat truncre verse ( upper : nat ) : nat -> nat. Proof, 
intros upper n. destruct C natgthorleh n upper ) as [ h I k ] . exact 
n. exact ( minus upper n ). Defined. 

Definition nattruncbottomtopswap ( upper : nat ) : nat -> nat. Proof, 
intros upper n. destruct ( isdeceqnat 0°/lnat n ) as [ h I k ] . exact ( 
upper ) . destruct ( isdeceqnat upper n ) as [1 I r ] . exact ( OVtUat 
). exact n. Defined. 

Lemma nattruncreverseisnattrimcauto ( upper : nat ) : isnattruncauto 
upper C nattruncreverse upper ) . Proof. intros. unfold 
isnattruncauto. split, intros m q, set C m' := minus upper m 
). assert ( natleh m' upper ) as aO, apply minusleh. assert C 
nattruncreverse upper m' ~> m ) as al. unfold 
nattruncreverse. destruct C natgthorleh m* upper ). assert 
empty, apply isirref Inatlth with ( n := m' ). apply natlehlthtrans 
with ( ra upper ), assumption, assumption, contradiction, unfold 
m' . rewrite doubleminuslehpaths . apply idpath. assumption, split with 
m' . split, assumption, split, assumption. intros n qq u. unfold 
m' . rewrite <- u. unfold nattruncreverse. destruct C natgthorleh n 
upper ) as [1 I r ]. assert empty, apply C isirref Inatlth n ). apply 
C natlehlthtrans _ upper 

) . assumption , assumption , contradiction , rewrite 

doubleminuslehpaths . apply idpath. assumption. intros x X . imf old 
nattruncreverse . destruct C natgthorleh x upper ) as [ 1 I r 
] . assumption, apply minusleh. Defined. 

Lemma nattruncbottomtopswapself inv C upper n ; nat ) : 
nattruncbottomtopswap upper ( nattruncbottomtopswap upper n ) "> n. 
Proof . intros . unfold nattruncbottomtopswap . destruct ( isdeceqnat 
upper n ) . destruct C isdeceqnat 0°/,nat n ) , destruct ( isdeceqnat 
0/inat upper ) . rewrite <- iO. rewrite <- il. apply idpath. assert 
empty, apply e. rewrite iO. rewrite i. apply idpath. contradiction, 
destruct C isdeceqnat Olinat OJinat ) . assumption . assert empty . apply 
eO. auto, contradiction, destruct C isdeceqnat 0°/,nat n ) . destruct C 
isdeceqnat 0°/,nat upper ) , rewrite <- i . rewrite iO . apply idpath. 
destruct ( isdeceqnat upper upper ) . assumption, assert empty, apply 
el. auto, contradiction, destruct ( isdeceqnat Oj^nat n ). assert 
empty, apply eO. assumption, contradiction. destruct C isdeceqnat 
upper n ). assert empty, apply e. assumption, contradiction, auto. 
Def ined . 

Lemma nattruncbottomtopswapbound ( upper n : nat ) ( p : natleh n 
upper ) : natleh (nattrimcbottomtopswap upper n ) upper. Proof, 
intros. unfold nattruncbottomtopswap. destruct (isdeceqnat OXnat n 
). auto, destruct C isdeceqnat upper n ). apply isreflnatleh. apply 
isreflnatleh. destruct ( isdeceqnat upper n ). apply 
natlehOn . assumption , Defined , 

Lemma nattruncbottomtopswapisnattruncauto ( upper : nat ) : 
isnattruncauto upper C nattruncbottomtopswap upper ) . Proof, 
intros. unfold isnattruncauto. split, intros m p. set ( m' := 



nattruncbottomtopswap upper m ). assert ( natleh m' upper ) as 
aO . apply nattruncbottomtopswapbound. assumption, assert 
(nattruncbottomtopswap upper m* ~> m) as al. apply 
nattruncbottomtopswapself inv. split with 

m' . split, assumption, split, assumption. intros k q u. unfold 
m' . rewrite <- u. rewrite nattruncbottomtopswapself inv. apply 
idpath. intros n p. apply nattruncbottomtopswapbound, assumption. 
Defined. 

Lemma isnattrimcautoOS ■[ upper : nat > { i : nat -> nat } C p : 
isnattruncauto (S upper) i ) ( j : i 0*/jiat "> S upper ) : 
isnattruncauto upper ( funcomp Si), Proof, intros. unfold 
isnattruncauto, split, intros m q. set ( v ;= nattruncautopreimage p 
(natlthtoleh m (S upper) (natlehlthtrans m upper (S upper) q 
Cnatlthnsn upper)))), destruct ( isdeceqnat 0/inat v ) as [ iO I il 
]. assert empty, apply C isirref Inatlth C i OXnat ) ). apply ( 
natlehlthtrans _ upper ). rewrite iO. unfold v, rewrite ( 
nattruncautopreima^epath ) . assumption, rewrite j . apply 
natlthnsn, contradiction. assert ( natlth v ) as aux. destruct ( 
natlehchoice _ _ C natlehOn v ) ). assumption, assert empty, apply 
il , assumption, contradiction. split with ( minus v 1 
), split, rewrite <- ( rainussnl upper ). apply C minuslleh aux ( 
natlehlthtrans _ _ _ C natlehOn upper ) { natlthnsn upper ) ) ( 
nat truncautopre image ineq p { natlthtoleh m ( S upper ) ( 
natlehlthtrans m upper { S upper ) q ( natlthnsn upper ) ) ) ) 
) , split . unfold funcomp, rewrite pathssminus , rewrite 
minussnl , apply nattruncautopreimagepath . assumption. intros n uu 
k. unfold funcomp in k. rewrite <- ( minussnl n ). assert ( v ~> S n 
) as f . apply ( nattruncautopreimagecanon p _ 
). assumption, assumption, rewrite f, apply idpath. intros x 
X, unfold funcomp. assert ( natleh CiCSx)) (S upper ) ) as 
aux, apply p. assumption, destruct C natlehchoice _ _ aux ) as [ h I k 
]. apply natlthsntoleh, assumption, assert empty, assert C 0/inat ~> S 
X ) as ii. apply ( nattruncautoisinj p ). apply natlehOn. assumption, 
rewrite j. rewrite k, apply idpath, apply C isirref Inatlth C S x ) ). 
apply C natlehlthtrans _ x ). rewrite <- ii. apply natlehOn. apply 
natlthnsn. contradiction. Defined, 

(* The following lemma says that we may reindex sums along 
automorphisms of the interval over which the finite summation is being 
taken . * ) 

Lemma natsummationre indexing ■[ R : commrng } -C upper : nat } ( i : nat 
-> nat ) C p : isnattruncauto upper i ) ( f ; nat -> R ) : 
natsummationO upper f ~> natsummationO upper (funcomp if). Proof, 
intros R upper, induction upper, intros. simpl, unfold funcomp. 
assert C 0°/«nat ~> i 0*/aiat ) as fO. destruct ( natlehchoice ( i 0*/jiat ) 
0%nat ( pr2 p OJinat ( isref Inatleh 0%nat )))as[h|k]. assert 
empty, exact ( negnatlthnO ( i O^nat ) h ). contradiction, rewrite 
k , apply idpath . rewrite <- f . apply idpath . intros , simpl ( 
natsummationO ( S upper ) f ). set ( j :^ nattruncautopreimagepath p 
C isref Inatleh ( S upper ) ) ). set ( v := nattruncautopreimage p ( 
isref Inatleh ( S upper ) ) ) . change ( nattruncautopreimage p ( 
isref Inatleh ( S upper ) ) ) with v in j . destruct ( natlehchoice 
0>Cnat V C natlehOn v ) ). set ( aaa := nat truncautopre image ineq p ( 
isreflnatleh ( S upper ) ) ) . change ( nattruncautopreimage p ( 
isreflnatleh ( S upper ) ) ) with v in aaa. destruct ( natlehchoice v 
( S upper ) aaa ) as [ 1 I r ] . rewrite ( IHupper ( funcomp ( 
natcof ace v ) i ) ) , 

change ( funcomp ( funcomp ( natcoface v ) i ) f ) with ( funcomp ( 
natcoface v ) ( funcomp if)), assert ( f ( S upper ) ~> ( 
funcomp i f ) V ) as fO. unfold funcomp. rewrite j. apply 
idpath. rewrite fO. 



assert ( natleh v upper ) as aux. apply natlthsntoleh. assumption. 



rewrite ( natsummationshif t upper ( funcomp if) aux ), apply 
idpath, apply precompwithnatcof aceisauto , assumption, 

rewrite ( IHupper ( funcomp ( natcoface v ) i ) ) , assert ( 
natsummationO upper ( fimcomp ( funcomp ( natcoface v ) i) f ) ~> 
natsummationO upper ( funcomp i f ) ) as fO. apply 
natsummationpathsupperf ixed, intros x X. unfold funcomp. unfold 
natcoface. assert ( natlth x v ) as aO. apply ( natlehlthtrans _ 
upper ). assumption, rewrite r. apply natlthnsn, rewrite aO. apply 
idpath, rewrite fO, assert ( f ( S upper ) ~> ( funcomp i f ) ( S 
upper ) ) as fl. unfold funcomp, rewrite <- r. rewrite j. rewrite 
<- r. apply idpath. rewrite fl, apply idpath, apply 
precompwithnatcof aceisauto . assumption . rewrite 
natsummationshif to , unfold funcomp at 2 , rewrite iO . rewrite j , 
assert ( i O'/oiat ~> S upper ) as j ' . rewrite iO. rewrite j. apply 
idpath. rewrite ( IHupper ( funcomp S i ) ( isnattruncautoOS p j' ) 
). apply idpath. Defined. 

(** * III. Formal Power Series *) 

Definition seqson ( A : UU ) ;= nat -> A. 

Lemma seqsonisaset ( A : hSet ) : isaset ( seqson A ). Proof, 
intros. unfold seqson. change C isofhlevel 2 ( nat -> A ) ). apply 
impredfun. apply A. Defined. 

Definition isasetfps C R : commrng ) : isaset ( seqson R ) := 
seqsonisaset R. 

Definition fps ( R : commrng ) : hSet := hSetpair _ ( isasetfps R ). 

Definition fpsplus ( R : commrng ) : binop ( fps R ) := fun v w n => ( 
(vn) + (wn) ). 

Definition fpstimes ( R : commrng ) : binop ( fps R ) fun s t n => 
natsummationO n ( fun x : nat =>(sx)*(t( minus n x ) ) ), 

(* SOME TESTS OF THE SUMMATION AND FPSTIMES DEFINITIONS: 

Definition testO : seqson hz. Proof. intro n. induction n. exact 
0, exact ( nattohz ( S n ) ), Defined, 

Eval lazy in ( hzabsval ( natsummationO 1 testO ) ). 

Definition testl : seqson hz. Proof. intro n. induction n. exact ( 1 
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: fps R 


= ( fun n : nat 


=> 


Definition fpsone C R : 
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fps R. 


Proof 


intros , 


intro 



n , destruct n , exact 1 , exact , Defined , 

Definition fpsminus ( R : commrng ) : fps R -> fps R := C fun s n => - 
( s n ) ). 

Lemma ismonoidopfpsplus ( R : commrng ) : ismonoidop ( fpsplus R ) . 



Proof , intros , unfold ismonoidcp . split , unfold isassoc . intros s t 
u. unfold fpsplus. (* This is a hack which should work immediately 
without such a workaround! *) change C (fun n : nat =>sn+tn+u 
n) ~> (fun n : nat => s n + (t n + u n)) ). apply funextfun. intro 
n. apply R. 

unfold isunital, assert C isunit C fpsplus R ) ( fpszero R ) ) 
as a. unfold isunit . split . unfold islunit . intro s . unfold 
fpsplus. unfold fpszero. change ( (fun n : nat => + s n) ~> s 
). apply funextfun. intro n. apply rnglunaxl . 

unfold isrunit. intro s. unfold fpsplus. unfold fpszero. 
change ( (fun n : nat => s n + 0) ~> s ) . apply funextfun. 
intro n. apply mgrunaxl. exact ( tpair ( fpszero R ) a ). 
Defined. 

Lemma isgropfpsplus ( R : commmg ) : isgrop ( fpsplus R ), Proof, 
intros. unfold isgrop. assert ( invstruct ( fpsplus R ) ( 
ismonoidopf psplus R ) ) as a. unfold invstruct. assert C isinv 
(fpsplus R) (unel_is (ismonoidopfpsplus R)) ( fpsminus R ) ) as b, 
unfold isinv , split . unfold islinv . intro s , unfold fpsplus . unfold 
fpsminus. unfold unel_is. simpl. unfold fpszero. apply 
funextfun, intro n. exact ( rnglinvaxl R ( s n ) ) . 

unfold isrinv. intro s. unfold fpsplus. unfold fpsminus. unfold 
unel_is, simpl. unfold fpszero. apply funextfun, intro n. exact ( 
rngrinvaxl R ( s n ) ). exact ( tpair ( fpsminus R ) b ). exact 
( tpair ( ismonoidopfpsplus R ) a ). Defined. 

Lemma iscommf psplus ( R : commrng ) : iscomm ( fpsplus R ). Proof, 
intros. unfold iscomm. intros s t. unfold fpsplus. change ((fun n : 
nat => s n + t n) ~> (fun n : nat => t n + s n) ). apply 
funextfun, intro n, apply R, Defined, 

Lemma isassocf pstimes ( R : commmg ) : isassoc (fpstimes R) . Proof . 
intros. imfold isassoc. intros s t u. unfold fpstimes. 

assert ( (fun n : nat => nat summat ionO n (fun x : nat => 

natsummationO ( minus n x) (fun xO : nat =>sx*(txO*u( 
minus ( minus n x ) xO) )))) ~> (fun n : nat natsummationO n 
(fun x : nat => s x * natsummationO ( minus n x) (fun xO : nat => 
t xO * u ( minus ( minus n x ) xO)))) ) as A. apply 
funextfun. intro n. apply 

nat siimmationpaths upper f ixed . intros . rewrite 

natsummationtimesdistr . apply idpath. rewrite <- A . assert ( (fun 
n : nat => natsummationO n (fun x : nat => natsummationO ( minus n 
x) (fun xO : nat =>sx*txO*u( minus ( minus nx ) xO )))) 
"> (fun n : nat => natsummationO n (fun x : nat => natsummationO ( 
minus n x) (fun xO : nat =>sx* (txO*uC minus ( minus n x ) 
xO) )))) ) as B, apply funextfun. intro n. apply 
maponpaths, apply funextfun, intro m, apply maponpaths. apply 
funextfun, intro x, apply R, assert ( (fun n : nat => 
natsummationO n (fun x : nat => natsummationO x (fun xO : nat => s 
xO * t ( minus x xO ) * u ( minus n x )))) ~> (fun n : nat => 
natsummationO n (fun x : nat => natsummationO ( minus n x) (fun xO 
: nat =>sx*txO*u( minus ( minus nx)xO)))) ) asC. 
apply funextfun. intro n. set ( f ;= fun x ; nat => ( fun xO : 
nat =>sx*txO*u( minus ( minus n x ) xO ) ) ) . assert ( 
natsummationO n ( fun x : nat => natsummationO x ( fun xO : nat => 
f xO ( minus x xO ) ) ) ~> ( natsummationO n ( fun x : nat => 
natsummationO ( minus n x ) ( fun xO : nat => f x xO ) ) ) ) as D, 
apply natsummationswap, unfold f in D. assert ( natsummationO n ( 
fun x : nat natsummationO x ( fun xO : nat s xO * t ( minus 
X xO ) * u ( minus n x ) ) ) ~> natsummationO n ( fun x : nat => 
natsummationO x ( fun xO : nat => s xO * t ( minus x xO ) * u ( 
minus ( minus n xO ) ( minus xxO)))))asE. apply 



nat summat ionpathsupperf ixed. intros k p, apply 

natsummationpathsupperf ixed. intros 1 q, rewrite ( natdoubleminus 
p q ). apply idpath. rewrite E, D. apply idpath. rewrite <- 
B. rewrite <- C. assert ( (fun n ; nat => natsummationO n (fun x 
: nat => natsummationO x (fun xO : nat => s xO * t ( minus x xO)) 
* u ( minus n x))) *"> (fun n : nat => natsummationO n (fun x : nat 
=> natsummationO x (fun xO : nat => s xO * t ( minus x xO) * u ( 
minus n x)))) ) as D. apply funextfun, intro n, apply 
maponpaths. apply funextfun. intro m, apply 

natsummationtimesdistl, rewrite <- D, apply idpath. Defined. 

Lemma nat summat ionandfpszero ( R : commrng ) : forall m : nat, 
natsummationO m ( fun x : nat => fpszero R x ) ~> ( Qrngunell R ), 
Proof. intros R m. induction m. apply idpath. simpl. rewrite 
IHm, rewrite ( rnglunaxl R ), apply idpath. Defined. 

Lemma ismonoidopf pstimes ( R : commrng ) : ismonoidop ( fpstimes R ) . 

Proof . intros . unfold ismonoidop , split , apply 

isassocf pstimes , split with ( f psone R) , split , intro s , unfold 

fpstimes. change ( C fun n : nat natsummationO n ( fun x : nat => 

fpsone R X * s ( minus nx) ) ) ~>s), apply funextfun, intro 

n, destruct n. simpl, rewrite ( rnglunax2 R ). apply idpath, rewrite 

natsummationshif to. rewrite ( rnglunax2 R) . rewrite minusOr, assert ( 

natsummationO n ( fun x : nat => fpsone RCSx)*s( minus n x ) ) 

~> ( ( natsummationO n ( fun x : nat => fpszero R x ) ) ) ) as 

f. apply natsummationpathsupperf ixed. intros m m' . rewrite ( rngmultOx 

R ). apply idpath, change ( natsummationO n ( fun x : nat => fpsone R 

( S X ) * s ( minus nx) )+s (Sn) ~> (s (Sn) ) ). rewrite 

f. rewrite natsummationandf pszero . apply ( rnglunaxl R ). 

intros s. unfold fpstimes. change ( ( fun n : nat => natsummationO n 
( fun X : nat => s x * fpsone R ( minus nx) ) ) ~>s). apply 
funextfun. intro n, destruct n. simpl. rewrite ( rngrunax2 R 
), apply idpath, change ( natsummationO n ( fun x : nat => s x * 
fpsone R ( minus (Sn)x))+s(Sn) * fpsone R ( minus n n ) 
~> s ( S n ) ). rewrite minusnnO. rewrite C mgrunax2 R ), assert ( 
natsummationO n ( fun x : nat => s x * fpsone R ( minus ( S n ) x )) 
~> ( ( natsummationO n ( fun x : nat => fpszero R x ) ) ) ) as 
f, apply natsummationpathsupperf ixed. intros m m' . rewrite <- 
pathssminus. rewrite ( rngmultxO R ), apply idpath, apply ( 
natlehlthtrans _ n ). assumption, apply natlthnsn. rewrite 
f. rewrite natsummationandf pszero. apply ( rnglunaxl R ). Defined. 

Lemma iscommfpstimes ( R : commrng ) ( s t : fps R ) ; fpstimes R s t 
~> fpstimes R t s. Proof, intros, unfold fpstimes. change ( ( fun n 
: nat => natsummationO n (fun x : nat => s x * t ( minus n x) ) ) ~> 
(fun n : nat => natsummationO n (fun x : nat => t x * s ( minus n x))) 
). apply funextfun. intro n. 

assert ( natsummationO n ( fun x : nat => s x * t ( minus n x ) ) ~> 
( natsummationO n ( fun x : nat => t ( minus nx)*sx)))as 
aO, apply maponpaths. apply funextfun. intro m. apply R. assert ( 
( natsummationO n ( fun x : nat => t ( minus nx)*sx))~>( 
natsummationO n ( funcomp ( nattruncreverse n ) ( fun x : nat => t x 
* s ( minus nx) ) ) ) ) asal. 

apply natsummationpathsupperf ixed. intros m q. unfold 
funcomp. unfold nattruncreverse. destruct (natgthorleh m n ). 
assert empty, apply isirref Inatlth with ( n := n ) . apply 
natlthlehtrans with ( m := m ) . apply h. assumption, contradiction, 
apply maponpaths. apply maponpaths. apply pathsinvO. apply 
doubleminuslehpaths . assumption, assert ( ( natsummationO n ( 
funcomp ( nattruncreverse n ) ( fun x : nat => t x * s ( minus n x ) 
) ) ) ~> natsummationO n ( fun x : nat => t x * s ( minus n x ) ) ) 
as a2. apply pathsinvO. apply natsummationreindexing. apply 



nattruncreverseisnattnincauto. exact ( pathscompO aO ( pathscompO al 
a2 ) ) . Defined. 

Lemma Isldistrfps ( R : commmg ) ( s t u : fps R ) : fpstimes R s ( 
fpsplus R t u ) ~> C fpsplus R ( fpstimes R s t ) ( fpstimes R s u ) 
). Proof. intros. unfold fpstimes. unfold fpsplus, change ((fun n ; 
nat => natsummationO n (fun x : nat => s x * (t (minus n x) + u ( 
minus n x) ) ) ) ~> (fun n : nat => natsummationO n (fun x : nat s x * 
t (minus n x)) + natsummationO n (fun x : nat => s x * u (minus n x))) 
). apply funextfun. intro upper, assert ( natsummationO upper ( fun 
X : nat => s x * ( t ( minus upper z ) + u ( minus upper x ) ) ) ~> ( 
natsummationO upper ( fun x : nat =>((sx*tC minus upper x ) ) + 
( s X * u ( minus upper x))))))asaO. apply maponpaths. apply 
funextfun, intro n, apply R, assert ( ( natsummationO upper ( fun x : 
nat =>((sx*t( minus upper x))+(sx*u( minus upper x ) ) 
)))">(( natsummationO upper ( fun x : nat => s x * t C minus 
upper X ))}-(- ( natsummationO upper ( fun x : nat => s x * u ( minus 
upper X ) ) ) ) ) as al. apply natsummationplusdistr. exact ( 
pathscompO aO al ). Defined. 

Lemma isrdistrfps ( R : commrng ) ( s t u : fps R ) : fpstimes R ( 
fpsplus R t u ) s ~> ( fpsplus R ( fpstimes R t s ) ( fpstimes R u s ) 
). Proof. intros. unfold fpstimes. unfold fpsplus. change ((fun n : 
nat => natsummationO n (fun x : nat => (t x + u x) * s ( minus n x ) 
)) ~> (fun n : nat => natsummationO n (fun x : nat => t x * s ( minus 
n X ) ) + natsummationO n (fun x : nat => u x * s (minus n x))) ). 
apply funextfun. intro upper, assert ( natsummationO upper ( fun x ; 
nat => (tx+ux) *s ( minus upper x ) ) ~> ( natsummationO upper 
C fun X : nat =>(Ctx*sC minus upper x))+(ux*s( minus 
upper x))))))asaO. apply maponpaths. apply funextfun. intro 
n, apply R, assert ( ( natsummationO upper ( fun x ; nat => ( ( t x * 
s ( minus upper x)) + (ux*s( minus upper x)))))"'>(( 
natsummationO upper ( fun x : nat => t x * s ( minus upper x ) ) ) + ( 
natsummationO upper ( fun x : nat => u x * s ( minus upper x ) ) ) ) ) 
as al. apply natsummationplusdistr. exact ( pathscompO aO al ) . 
Defined. 

Definition fpsrng ( R : commrng ) := setwith2binoppair ( hSetpair ( 
seqson R ) ( isasetfps R ) ) ( dirprodpair ( fpsplus R ) ( fpstimes R 
) ). 

Theorem fpsiscomming ( R : commmg ) : iscommrng ( fpsrng R ). Proof, 
intro . unfold iscommrng , imf old iscommrngops . split . unfold 
isrngops , split . split , unfold isabgrop . split . exact ( isgropf psplus 
R ) . exact ( iscommf psplus R ) . exact ( ismonoidopfpstimes R ) , 
unfold isdistr . split . unfold isldistr . intros . apply ( isldistrfps R 
). unfold isrdistr. intros. apply ( isrdistrfps R ). unfold 
iscomm. intros. apply ( iscommfpstimes R ) . Defined. 

Definition fpsccmmrng ( R : commrng ) : commmg := commmgpair C 
fpsrng R ) ( fpsiscommrng R ) , 

Definition fpsshift ■[ R : commrng } ( a : fpscommmg R ) : fpscommmg 
R : = fun n : nat => a ( S n ) . 

Lemma fpsshiftandmult { R : commrng > ( a b ; fpscommmg R ) ( p : b 
07,nat ~> ) : forall n : nat, (a*b)(Sn)~>((a*( fpsshift 
b ) ) n ). Proof. intros, induction n. change ( a * b ) with ( 
fpstimes R a b ) . change (a * fpsshift b ) with ( fpstimes R a ( 
fpsshift b ) ). unfold fpstimes. unfold fpsshift. simpl. rewrite 
p. rewrite C mgmultxO R ). rewrite C rngrunaxl R ). apply idpath. 
chajige ( a ♦ b ) with ( fpstimes R a b ) . change (a * fpsshift b ) 
with ( fpstimes R a ( fpsshift b ) ). unfold fpsshift. unfold 
fpstimes. change ( natsummationO (S (S n)) (fun x : nat => a x * b 
(minus ( S (S n) ) x)) ) with ( ( natsummationO ( S n ) ( fun x : nat 
=> a X * b ( minus (S(Sn) )x) ) )+aCS(Sn))*b( minus 



(S(Sn))(S(Sn)))), rewrite minusnnO. rewrite p. rewrite 
( mgmultxO R ) . rewrite rngrunaxl . apply 

natsummationpathsupperf ixed. intros x j. apply maponpaths. apply 
maponpaths. rewrite pathssminus. apply idpath. apply ( natlehlthtrans 
_ ( S n ) _ ). assumption, apply natlthnsn. Defined. 

(** * IV. Apartness relation on formal power series *) 

Lemma apartbinarysumO ( R : acommrng ) (ab:R) (p:a+b#0) : 
hdisj (a#0) (b#0). Proof. intros. intros P s. apply ( 
acommrng_acotrans R(a+b)a0p). intro k. destruct k as C 1 I r 
]. apply s. apply ii2. assert Ca+b#a) asl'. apply 1. assert C 
(a+b) # (a+0 ) ) asl*'. rewrite rngrunaxl. assumption, apply 
( ( prl ( acommrng_aadd R ) ) a b ). assumption, apply s. apply 
ill . assumption. Defined. 

Lemma apartnatsummationO C R : acommrng ) ( upper : nat ) ( f : nat -> 

R ) ( p : ( natsummationO upper f ) # ) ; hexists ( fun n : nat => 
dirprod ( natleh n upper ) (fn#0) ). Proof. intros R 
upper . induction upper . simpl , intros . intros P s . apply s . split with 
O'/^nat. split, intros g. simpl in g. apply 

nopathsf alsetotrue . assumption, assumption. intros. intros P s, simpl 
in p. apply ( apartbinarysumO R _ _ p ). intro k. destruct k as [1 I 
r ]. apply ( IHupper f 1 ). intro k. destruct k as [ n ab ] . destruct 
ab as [ a b ]. apply s. split with n. split, apply C istransnatleh _ 
upper _ ) . assumption, apply natlthtoleh. apply 

natlthnsn. assumption, apply s. split with C S upper ). split, apply 
isref Inatleh. assumption. Defined. 

Definition fpsapartO C R : acommrng ) : hrel ( fpscommmg R ) := fun s 
t : fpscommmg R => ( hexists ( fun n : nat => (sn#tn) ) ). 

Definition fpsapart ( R : acommrng ) : apart ( fpscommmg R ). Proof, 
intros. split with ( fpsapartO R ). split, intros s f. assert ( 
hfalse ) as i . apply f. intro k. destmct k as [ n p ]. apply ( 
acommrng_airref 1 R ( s n ) p) . apply i. split, intros s t p P 
j. apply p. intro k. destruct k as [ n q ]. apply j. split with 
n. apply ( acommrng_asymm R(sn) (tn)q). intros s t u p P 
j. apply p. intro k. destruct k as [ n q ]. apply ( acommrng_aco trans 
R(sn) (tn) (un)q). intro 1. destruct 1 as [1 I r ]. 
apply j. apply iil. intros v V. apply V. split with n. assumption, 
apply j. apply ii2. intros v V. apply V. split with n. assumption. 
Defined. 



Lemma f psapartisbinopapartplusl ( R : acommrng ) : isbinopapartl ( 
fpsapart R ) ( Qopl ( fpscommmg R ) ). Proof. intros. intros a b c 
p. intros P s. apply p. intro k. destruct k as [ n q ]. apply 
s. change C Ca+b)n) with C(an)+(bn))inq. change ( ( 
a + c ) n ) with ((an)+(cn))inq. split with n. apply ( ( 
prl C acommmg_aadd R) ) (an) (bn) (cn) q). Defined. 

Lemma f psapartisbinopapartplusr ( R : acommrng ) : isbinopapartr ( 
fpsapart R ) ( Sopl ( fpscommrng R ) ). Proof. intros. intros a b c 
p. rewrite ( rngcomml ( fpscommmg R ) ) in p. rewrite ( rngcomml ( 
fpscommrng R ) c ) in p. apply ( f psapartisbinopapartplusl _ a b c 
) . assumption. Defined. 

Lemma fpsapartisbinopapartmultl ( R : acommrng ) : isbinopapartl ( 
fpsapart R ) ( Qop2 ( fpsrng R ) ). Proof. intros. intros a b c 
p. intros P s. apply p. intro k. destruct k as [ n q ]. change C ( a 
* b ) n ) with ( natsummationO n ( fun x : nat =>(ax)*(b( 
minus n x ) ) ) ) in q. change ( (a*c)n) with ( natsummationO n 
( fun X : nat =>(ax)*(c( minus nx) ) ) ) inq. assert ( 
natsummationO n ( fun x : nat => ( a x * b ( minus nx)-(ax*c( 
minus nx))))#0)asq'. assert ( natsummationO n ( fun x : nat 
=> ( a X * b ( minus n x ) ) ) - natsummationO n ( fun x : nat => ( a 



x * c C minus nx) ) ) #0) asq''. apply aaminuszero. assumption, 
assert C (fun x : nat => a x * b (minus nx) -ax*c ( minus n x)) 
~> (fun X : nat => a x * b ( minus n x) + C - Ijirng )*{ax*cC 
minus n x) ) ) ) as i . apply f unextf un . intro x . apply 
maponpaths. rewrite <- C mgmultwithminusl R ). apply idpath. rewrite 
i. rewrite natsummationplusdi&tr . rewrite <- ( natsummationtimesdistr 
n C fun X : nat => a x * c ( minus n x ) ) ( - l7,rng ) ) . rewrite ( 
mgmultwitliminusl R ). assumption. apply ( apairtnatsummationO R n _ 
q' ). intro k. destruct k as [ m g ]. destruct g as [ g g' ]. apply 
s. split with C minus n m ). apply ( ( prl ( acommrng_amult R ) ) ( a 
m ) ( b ( minus n m ) ) ( c ( minus n m ) ) ) . apply 
aminuszeroa. assumption. Defined. 

Lemma fpsapartisbinopapartmultr ( R : acommrng ) : isbinopapartr ( 
fpsapart R ) C Sop2 ( fpsrng R ) ). Proof. intros. intros a b c 
p. rewrite C nigcomm2 ( fpscommmg R ) ) in p. rewrite ( mgcomm2 ( 
fpscommmg R ) c ) in p. apply ( fps apart isbinopapartmultl _ a b c 
) , assumption. Defined. 

Definition acommrngfps { R : acommrng ) : acommrng. Proof . 
intros, split with { fpscommmg R ). split with ( fpsapart R 
) , split . split . apply ( f psapartisbinopapartplusl R) . apply C 
fpsapart isbinopapartplusr R ) . split, apply ( 

fpsapart isbinopapartmultl R ) . apply ( fpsapartisbinopapartmultr R ) . 
Defined. 

Definition isaconmirngapartdec ( R : acommrng ) := isapartdec ( ( prl ( 
pr2 R ) ) ) . 

Lemma leadingcoef f icientapartdec ( R : aintdom ) ( a : fpsconmirng R ) 
( is : isacommrngapartdec R ) ( p ; a 0%nat # ) : forall n ; nat, 
forall b : fpscommmg R, Cbn#0)->({ acommrng apartrel ( 
acommrngfps R)) Ca*b)0). Proof. intros R a is p n. induction 
n. intros b q. intros P s. apply s. split with 0%nat. change ( ( a * 
b ) Oiinat ) with ( ( a 0*/aiat ) * ( b 0*/jiat ) ) . apply 



7.5 The file frac.v 



(** *The Heyting field of fractions for an apartness domain *) 
(** By Alvaro Pelayo, Vladimir Voevodsky and Michael A. Warren *) 
(** Febmary 2011 and August 2012 *) 
(** Settings *) 

Add Rec LoadPath "../Generalities". Add Rec LoadPath " . ./hlevell" . 
Add Rec LoadPath " . ./hlevel2" . Add Rec LoadPath "../Algebra". 

Unset Automatic Introduction. (** This line has to be removed for the 
file to compile with Coq8.2 *) 

(** Imports *) 

Require Export lemmas . 

(** * I . The field of fractions for an integrable domain with an 
apartness relation *) 

Open Scope rng_scope. 
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R. assumption, assumption. intros b q, destruct ( is ( b O/inat ) ) 

as [ left I right ]. intros P s. apply s. split with O^jiat. change ( 

C a * b ) 0°/,nat ) with ( C a OXnat ) * ( b 0*/aiat ) ) . apply 

R. assumption, assumption. assert C ( acommrngapartrel ( acommrngfps 

R ) ) C a * ( fpsshift b ) ) ) as j . apply IHn. unfold 

f psshif t . assumption, apply j, intro k. destruct k as [ k i ]. intros 

P s. apply s. rewrite <- ( f psshif tandmult a b right k ) in i . split 

with C S k ). assumption. Defined. 

Lemma apartdecintdomO ( R : aintdom ) ( is : isacommrngapartdec R ) : 
forall n : nat, forall a b : fpscommmg R, Can#0)->C 
acommrngapartrel ( acommmgfps R ) b ) -> C acommmgapartrel ( 
acommrngfps R) Ca*b)0). Proof. intros R is n. induction 
n. intros a b p q, apply q. intros k. destruct k as [ k kO ] , apply ( 
leadingcoef f icientapartdec R a is p k ) . assumption, intros a b p 
q. destmct C is C a 07.nat ) ) as [ left I ri^t ] . apply q. intros 
k. destmct k as [ k kO ] . apply ( leadingcoef f icientapartdec R a is 
left k ), assumption. assert ( acommmgapartrel ( acommrngfps R ) ( ( 
fpsshift a) *b) 0) asi. apply IHn. unfold 

fpsshift . assumption . assumption . apply i , intros k . destruct k as [ 
k kO ] . intros P s. apply s. split with ( S k ). rewrite 
mgcomm2. rewrite f psshif tandmult . rewrite 
mgcomm2. assumption, assumption. Defined. 

Theorem apartdect oi saint domfps C R : aintdom ) C is : 
isacommrngapartdec R ) : aintdom. Proof . intros R, split with ( 
acommrngfps R ). split, intros P s. apply s. split with 0°/,nat . change 
( C Smgunell ( fpsconmirng R ) ) OXnat ) with ( Qrngunell R ) . change 
C Qmgunel2 R # ( Qrngunell R ) ). apply R. intros a b p q. apply 
p. intro n. destruct n as [ n nO ] . apply C apartdecintdomO R is n) 
. as sumpt ion, as sumpt i on . Def ined . 

Close Scope rng_scope. 

(** END OF FILE *) 



Section aint . 



Variable A ; aintdom. 

Ltac permute := solve [ repeat rewrite rngassoc2; match goal with I [ 
I- ?X ~> ?X ] => apply idpath I [ I - ?X * ?Y ~> ?X * ?Z ] => apply 
maponpaths; permute I [ I - ?Y * ?X ~> ?Z * ?X ] => apply C 
maponpaths C fun x => x * X ) ) ; permute | [ I - ?X * ?Y ~> ?Y * ?X ] 
=> apply rngcomm2 I [ I - ?X ♦ ?Y ~> ?K ] => solve [ repeat rewrite 
<- rngassoc2; match goal with I [ I - ?H ~> ?V * X ] => rewrite ( 
Qmgcomm2 A V X ); repeat rewrite mgassoc2; apply maponpaths; 
permute end I repeat rewrite rngassoc2; match goal with I [ |- ?H "> 
?Z * ?V ] => repeat rewrite <- mgassoc2; match goal with I [ |- ?W 
* Z ~> ?L ] => rewrite ( Srngcomm2 A W Z ) ; repeat rewrite 
rngassoc2; apply maponpaths; permute end end ] I [ I - ?X * ( ?Y * ?Z 
) ~> ?K ] => rewrite ( Qrngcomm2 A Y Z ) ; permute end I repeat 
rewrite <- rngassoc2; match goal with I [ |- ?X * ?Y ~> ?X * ?Z ] => 
apply maponpaths; permute I [ |- ?Y * ?X ~> ?Z * ?X ] => apply ( 
maponpaths ( fun x => x * X ) ); permute I [ I - ?X * ?Y ~> ?Y * ?X ] 
=> apply rngcomm2 end I apply idpath I idtac "The tactic permute 
does not apply to the current goal!" ]. 

Lemma azerorelcomp ( cd : dirprod A ( aintdomazerosubmonoid A ) ) ( ef 
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: dirprod A ( aintdomazerosubmonoid A ) ) ( p : ( prl cd ) * ( prl { 
pr2 ef ) ) ~> C C prl ef ) * ( prl C pr2 cd ) ) ) ) C q : C prl cd ) # 
) : C prl ef ) #0. Proof. intros . change ( C ®op2 A ( prl cd ) ( 
prl C pr2 ef ) ) ) '> C i3op2 A ( prl ef ) ( prl ( pr2 cd ) ) ) ) in p. 
assert C ( 9op2 A ( prl cd ) ( prl ( pr2 ef ) ) ) # ) as v. apply 
A. assumption, apply ( pr2 C pr2 ef ) ) . rewrite p in v. apply C prl ( 
timesazero v ) ). Defined. 

Lemma azerolmultcomp {abc:A}Cp:a#0) Cq:b#c) :a*b 

# a * c. Proof, intros, apply aminuszeroa. rewrite <- 
mgminusdistr. apply C pr2 A ). assumption. apply 
aaminuszero . assumption. Defined. 

Lemma azerormultcomp {abc:A}Cp:a#0) {q:b#c) :b*a 

# c * a. Proof, intros. rewrite ( Srngcomm2 A b ). rewrite C 
Qmgcomm2 Ac), apply ( azerolmultcomp p q ). Defined. 

Definition afldfrac apart re Ipre : hrel C dirprod A ( 

aintdomazerosubmonoid A ) ) fun ab cd : _ C ( prl ab ) * ( prl ( 
pr2 cd ) ) ) # ( C prl cd ) * C prl ( pr2 ab ) ) ). 

Lemma af Idf racapartiscoraprel : iscomprelrel ( eqrelcommrngf rac A C 
aintdomazerosubmonoid A ) ) ( afldfrac apart re Ipre ) . Proof . intros 
ab cd ef ^ p q. unfold afldfracapartrelpre. destruct ab as [ a b 
] . destruct b as [ b b * ] . destruct cd as [ c d ] . destruct d as [ d 
d' ] . destruct ef as C e f ] . destruct f as [ f f ' ] . destruct ^ as 
[ g h ] . destruct h as [ h h' ] . simpl in *. 

apply uahp. intro u. apply p. intro p'. apply q. intro q* . destruct 
p' as [ p' j ] . destruct p' as [ i p' ]. destruct q* as [ q* j' 
], destruct q' as [ i' q' ] . simpl in *. 

assert Ca*f*d*i*h*i' #e*b*d*i*h*i') asvO. 
assert {a*f *d#e*b*d) asvO. apply azerormultcomp. apply 
d' . assumption. assert Ca*f*d*i#e*b*d*i)as 
vl. apply azerormultcomp. assumption, assumption. assert ( a * f * 
d*i*h#e*b*d*i*h) asv2. apply azerormultcomp. apply 
h' . assumption. apply azerormultcomp. assumption, assimiption. 
apply ( pr2 ( acommrng_amult A ) b ) . apply C pr2 ( acommmg_amult A 
) f ) . apply C pr2 ( acommmg_amult A ) i ) . apply C pr2 ( 
acommmg_amult A ) i ' ) . 

assert (a*f*d*i*h*i' ~>c*h*b*f*i*i' ) asl. 
assert Ca*f*d*i*h*i' ~>a*d*i*f*h*i' )as 10. 
change ( @op2 A ( @op2 A ( @op2 A ( Sop2 A ( Sop2 A a f ) d ) i ) h 
) i' ~> Qop2 A C aop2 A ( 9op2 A ( Sop2 A ( Qop2 Aad)i)f)h) 
i ' ) . permute . rewrite 10 . rewrite j . change C Qop2 A C Qop2 A ( 
aop2 A ( aop2 A ( aop2 Acb)i)f)h)i**> Qop2 A C Qop2 A C 
9op2 A C 'aop2 A C ®op2 Ach)b)f)i)i'). permute, rewrite 1 
in vO. assert Ce*b*d*i*h*i' ~>g*d*b*f*i*i' ) 
as k. assert ( Sop2 A C (3op2 A C @op2 A ( @op2 A C @op2 A e b ) d ) 
i ) h ) i' "■> Qop2 A ( ©op2 A ( Sop2 A ( Sop2 A ( Sop2 A e h ) i' ) 
i ) b ) d ) as kO. permute. change ( @op2 A C aop2 A ( @op2 A ( 
Qop2 A C Qop2 Aeb)d) i)h) i' '> Qop2 A ( Qop2 A ( Qop2 A ( 
Qop2 A ( 9op2 Agd)b)f)i)i'). rewrite kO. assert ( Qop2 A 
C •3op2 A e h ) i' ~> iaop2 A ( @op2 A g f ) i' ) as j ' ' . assumption, 
rewrite j*'. permute, rewrite k in vO. assumption. 

intro u. apply p. intro p' . apply q. intro q' . destruct p' as [ p' 
j ]. destruct p' as [ i p' ] . destruct q' as C q' j ' 3 • destruct q' 
as [ i' q' ] . simpl in *. 

assert Cc*h*b*f*i*i' #g*d*b*f*i*i' ) as v. 
apply azerormultcomp. apply q' . apply azerormultcomp. apply p' . 
apply azerormultcomp. apply f. apply azerormultcomp. apply 
b' . assumption, apply { pr2 ( acommmg_amult A ) d ). apply C pr2 ( 



acommrng_amult A ) h ) . apply ( pr2 C acommnig_amult A ) i ) . apply 
C pr2 ( acommrng_amult A ) i' ). 



assert Cc*h*b*f*i*i' ~>a*f*d*h*i*i' ) ask. 
assert (c*h*b*f*i*i' ~>c*b*i*f*h*i' ) askO. 
change ( i2op2 A C ©op2 A C Sop2 A ( @op2 A C @op2 A c h ) b ) f ) i 
) i' '> Sop2 A ( Sop2 A ( Sop2 A ( Sop2 A ( i3op2 A c b ) i ) f ) h ) 
i' ). permute, rewrite kO. rewrite <- j. change C i3op2 A C @op2 A ( 
@op2 A ( @op2 A ( Sop2 Aad)i)f)h)i'~> @op2 A ( @op2 A ( 
Qop2 A ( Sop2 A ( Qop2 Aaf)d)h)i)i'). permute, rewrite k 
in V. assert (g*d*b*f*i*i' ~>e*b*d*h*i*i' ) 
as 1. assert Cg*d*b*f*i*i' ~>g*f*i' *d*i*b) 
as 10. change ( Sop2 A ( Sop2 A ( Sop2 A ( Qop2 A C Sop2 A g d ) b 
) f ) i ) i' ~> ®op2 A ( @op2 A ( ©op2 A ( ©op2 A ( ©op2 A g f ) i' 
) d ) i ) b ). permute, rewrite 10. rewrite <- j ' . change CQop2 A ( 
Qop2 A C Qop2 A C Qop2 A C Qop2 Aeh)i')d)i)b~> Qop2 A ( 
Qop2 A C Qop2 A ( Qop2 A ( Qop2 Aeb)d)h) i) i' 
) . permute, rewrite 1 in v. assumption. Defined. 

{** We now arrive at the apartness relation on the field of fractions 

itself.*) 

Definition af Idf racapartrel quotrel af Idf racapartiscoraprel . 

Lenmia isirref laf Idf racapartrelpre : isirref 1 afldfracapartrelpre . 
Proof . intros ab, apply acommrng_airref 1 , Defined. 

Lemma issymmaf Idf racapartrelpre : issymm afldfracapartrelpre. Proof, 
intros ab cd. apply C acommiiig_asymm A ). Defined. 

Lemma iscotransaf Idf racapartrelpre : iscotrans afldfracapartrelpre , 
Proof, intros ab cd ef p, destruct ab as [ a b ], destruct b as [ b 
b' ]. destruct cd as [ c d ] . destruct d as [ d d' ] . destruct ef as 
[ e f ] . destruct f as [ f f ' ] , assert Ca*f*d#e*b*d)as 
V. apply azerormultcomp, assumption . assumption . apply C C 
acommrng_acotrans A(a*f*d) {c*b*f) (e*b*d))v 
), intro u, intros P k. apply k. unfold afldfracapartrelpre in 
*. simpl in *. destruct u as [ left I right ]. apply iil. apply C pr2 
( acommrng.amult A ) f ) . assert C @op2 A C iSop2 A a f ) d '> (§op2 A 
( Qop2 Aad)f)asi. permute. change ( @op2 A { Sop2 A a d ) f # 
9op2 A ( Qop2 A c b ) f ), rewrite <- i. assumption, apply ii2. apply 
C pr2 ( acommrng_aniult A ) b ) . assert ( @op2 A ( @op2 A c f ) b ~> 
9op2 A ( @op2 Acb)f)asi. permute. change ( @op2 A C @op2 A c f 
) b # Qop2 A ( iSop2 A e d ) b ). rewrite i. assert ( ©op2 A ( Sop2 A 
e d ) b "> Sop2 A ( Sop2 Aeb)d)asj. permute. change ( i2op2 A C 
Qop2 A c b ) f # Sop2 A ( 9op2 A e d ) b ), rewrite j. assumption. 
Defined. 

Lemma isapartaf Idf racapartrel : isapart af Idf racapartrel . Proof , 
intros . split . apply isirref Iquotrel , exact C 

isirref laf Idf racapartrelpre ) . split . apply issymmquotrel , exact ( 
issymmaf Idf racapartrelpre ) . apply iscotransquotrel. exact ( 
iscotransaf Idf racapartrelpre ) . Defined . 

Definition af Idf racapart : apart ( commrngfrac A 

(aintdomazerosubmonoid A)). Proof. intros. unfold apart, split with 
af Idf racapartrel , exact isapartaf Idf racapartrel . Defined. 

Lemma isbinapartlaf Idf racopl : isbinopapartl af Idf racapart opl . 

Proof, intros. unfold isbinopapartl. assert ( forall a b c : 

commrngfrac A C aintdomazerosubmonoid A ) , isaprop C prl 

(af Idf racapart) ( commrngf racopl A ( aintdomazerosubmonoid A ) a b) ( 

commrngf racopl A ( aintdomazerosubmonoid A ) a c) -> prl 

(af Idf racapart ) b c) ) as int. intros a b c. apply impred. intro 

p. apply ( prl ( af Idf racapart ) b c ). apply ( setquotuniv3prop _ ( 

fun a b c => hProppair _ ( int a b c ) ) ) . intros ab cd ef 



p. destruct ab as [ a b ] . destruct b as [ b b' ] . destruct cd as [ c 
d ] . destruct d as [ d d' ] , destruct ef as [ g f ] . destruct f as [ 
f f* ]. unfold af Idfracapart in *. simpl. unfold 

af Idf racapartrel . unfold quotrel . rewrite setquotuniv2comm . unfold 
af Idfracapart re Ipre . simpl . 

assert C af Idf racapartrelpre ( dirprodpair ( Sopl A { Sop2 A d a ) C 
@op2 Abe)) C @op ( aintdomazerosubmonoid A ) C tpair b b' ) { 
tpair d d' ) ) ) C dirprodpair ( Qopl A ( Sop2 A f a ) ( Qop2 Abe 
) ) C Sop C aintdomazerosubmonoid A ) ( tpair b b' ) ( tpair f f ' ) 
) ) ) as u. apply p. unfold afldfracapartrelpre in u. simpl in 
u. rewrite 2! C Qrngrdistr A ) in u. repeat rewrite <- mga5soc2 in 
u. assert C C@op2 (prlrng (commrngtorng (acommrngtocommrng 
(prlaintdom A) ) ) ) {©op2 (prlrng (commrngtorng (acommrngtocommrng 
(prlaintdom A)))) (Sop2 (Qprl SGtwith2binop (fun X : setwith2binop 
=> Qiscomramgops Cprlsetwith2binop X) (Qopl X) CiSop2 X)) 
C acommrngtocommrng (prlaintdom A))) da) b) f) ~> (<9op2 (prlrng 
(commrngtorng (acommrngtocommrng (prlaintdom A) ) ) ) (Sop2 (prlrng 
(commrngtorng (acommrngtocommrng (prlaintdom A) ) ) ) (Qop2 (Qprl 
setwith2binop (fun X : setwith2binop => Qiscommrngops 
(prlsetuith2binop X) (Qopl X) (Qop2 X) ) (acommrngtocommrng 
(prlaintdom A))) f a) b) d) ) as i, permute, rewrite i in u. assert 
( (©op2 (prlrng (commrngtorng (acommrngtocommrng (prlaintdom A) ) ) ) 
(Sop2 (prlrng (commrngtorng (acommrngtocommrng (prlaintdom A) ) ) ) 
(Qop2 (Sprl setwith2binop (fun X : setwith2binop => fliscommrngops 
(prlsetwith2binop X) (©opl X) (@op2 X) ) (acommrngtocommrng 
(prlaintdom A))) b c) b) f) ~> (@op2 (prlrng (commrngtorng 
(acommrngtocommrng (prlaintdom A) ) ) ) (Qop2 (prlrng (commrngtorng 
(acommrngtocommrng (prlaintdom A) ) ) ) (<3op2 (Qprl setwith2binop (fun 
X : setwith2binop => Siscommmgops (prlsetwith2binop X) (flopl X) 
(@op2 X)) (acommrngtocommrng (prlaintdom A))) c f) b) b) ) as 
j , permute, rewrite j in u. assert ( (@op2 (prlrng (commrngtorng 
(acommrngtocommrng (prlaintdom A) ) ) ) (Qop2 (prlrng (commrngtorng 
(acommrngtocommrng (prlaintdom A) ) ) ) (@op2 (@prl setwith2binop (fun 
X : setwith2binop => Siscommmgops (prlsetuith2binop X) (@opl X) 
(@op2 X)) (acommrngtocommrng (prlaintdom A))) be) b) d) ~> (9op2 
(prlrng (commrngtorng (acommrngtocommrng (prlaintdom A) ) ) ) (Qop2 
(prlrng (commrngtorng (acommrngtocommrng (prlaintdom A) ) ) ) (Qop2 
(@prl setwith2binop (fun X : setwith2binop => Siscommrngops 
(prlsetuith2binop X) (@opl X) (@op2 X) ) (acommrngtocomjnrng 
(prlaintdom A))) e d) b) b) ) as j ' . permute, rewrite j' in u. 
apply ( pr2 ( acoramrng_amult A ) b ) . apply ( pi'2 ( acomiiitTig.amult 
A ) b ) . apply ( prl ( acommrng_aadd A) (f*a*b*d) 
) . assumption. Defined. 

Lemma isbinapartraf Idf racopl : isbinopapartr af Idf racapart opl . 
Proof. intros a b c. rewrite ( mgcomml ). rewrite ( mgcomml _ c 
) . apply isbinapartlaf Idf racopl . Defined. 

Lemma isbinapartlaf Idf racop2 : isbinopapartl af Idf racapart op2 . 

Proof, intros, unfold isbinopapartl. assert ( forall a b c : 

commmgfrac A ( aintdomazerosubmonoid A ) , isaprop ( prl 

(af Idf racapart ) ( corararngf racop2 A ( aintdomazerosubmonoid A ) a b) ( 

commrngf racop2 A ( aintdomazerosubmonoid A ) a c) -> prl 

(af Idf racapart ) b c) ) as int. intros a b c. apply impred. intro 

p, apply ( prl ( af Idf racapaxt ) b c ). apply ( setquotunivSprop _ ( 

fun a b c => hProppair _ ( int a b c ) ) ). intros ab cd ef p. 

destruct ab as [ a b ]. destruct b as [ b b' ]. destruct cd as [ c 
d ] . destruct d as [ d d' ] . destruct ef as [ e f ] . destruct f as 

[ f f ' ]. 

assert ( afldfracapartrelpre ( dirprodpair ((a*c)) ( Sop ( 
aintdomazerosubmonoid A ) ( tpair b b' ) ( tpair d d' ) ) ) ( 
dirprodpair ( a * e ) ( flop ( aintdomazerosubmonoid A ) ( tpair b b' 
) ( tpair ff ) ) ) ) asu. apply p. xmfold af Idf racapart in 



*. simpl, unfold af Idf racapartrel . unfold quotrel. rewrite ( 
setquotuniv2comm ( eqrelcommrngfrac A ( aintdomazerosubmonoid A ) ) 
). unfold afldfracapartrelpre in *. simpl. simpl in u. apply ( pr2 
( acommmg_amult A ) a ) . apply ( pr2 ( acommnig_amult A ) b ) . 

assert (c*f*a*b~> (Sop2 (@prl setwith2binop (fun X : 
setwith2binop => Siscommrngops (prlsetwith2binop X) (Sopl X) (Sop2 
X) ) (acommrngtocommrng (prlaintdom A) ) ) (Sop2 (Sprl setwith2binop 
(fun X : setwith2binop => Siscommrngops (prlsetwitli2binop X) (Qopl 
X) (Qop2 X)) (acommrngtocommrng (prlaintdom A))) a c) (3op2 (Qprl 
setwith2binop (fun X : setwith2binop => Siscommrngops 
(prlsetwith2binop X) (Sopl X) (Sop2 X) ) (acommrngtocommrng 
(prlaintdom A))) b f)) ) as i. change (c*f*a*b~>a*c* (b 
* f ) ) . permute. change (c*f*a*b#e*d*a*b). rewrite 
i. assert (e*d*a*b~> (Qop2 (Qprl setwith2binop (fun X : 
setwith2binop => Qiscommmgops (prlsetwith2binop X) (Qopl X) (Qop2 
X) ) (acommingtocommrng (prlaintdom A) ) ) (Sop2 (Qprl setwith2binop 
(fun X : setwith2binop => Siscommrngops (prlsetwith2binop X) (Sopl 
X) (Qop2 X)) (acommrngtocommrng (prlaintdom A))) a e) (Sop2 (Sprl 
setwith2binop (fun X : setwith2binop => Siscommrngops 
(prlsetwith2binop X) (Sopl X) (Sop2 X) ) (acommrngtocommrng 
(prlaintdom A))) b d)) ) as i'. change (e*d*a*b~>a*e* ( 
b * d ) ). permute, rewrite i' . assumption. Defined. 

Lemma isbinapartraf Idf racop2 : isbinopapartr (af Idf racapart ) op2. 
Proof. intros a b c, rewrite rngcomm2. rewrite ( mgcomm2 _ c 
) . apply isbinapartlaf Idf racop2. Defined. 

Definition afldfracO : acommmg. Proof. intros. split with ( 
commrngf rac A ( aintdomazerosubmonoid A ) ) , split with ( 
af Idf racapart ) . split . split . apply ( isbinapartlaf Idf racopl 
) . apply ( isbinapartraf Idfracopl ) . split . apply ( 

isbinapartlaf Idf racop2 ). apply ( isbinapartraf Idf racop2 ). Defined. 

Definition af Idf racmultinvint ( ab : dirprod A ( aintdomazerosubmonoid 
A ) ) ( is : afldfracapartrelpre ab ( dirprodpair ( Srngunell A ) ( 
unel ( aintdomazerosubmonoid A ) )) ) : dirprod A ( 
aintdomazerosubmonoid A ), Proof. intros. destruct ab as [ a b 
]. destruct b as [ b b' ], split with b. simpl in is. split with 
a. unfold afldfracapartrelpre in is. simpl in is. change ( a # 
). rewrite ( QrngmultOx A ) in is. rewrite ( Qmgrunax2 A ) in 
is . assumption. Defined. 

Definition af Idf racmultinv ( a : afldfracO ) ( is : a # ) : 
multinvpair afldfracO a. Proof . intros . assert ( forall b : 
afldfracO, isaprop ( b # -> multinvpair afldfracO b ) ) as int. 
intros. apply impred. intro p. apply ( isapropmultinvpair afldfracO ). 
assert ( forall b : afldfracO, b # -> multinvpair afldfracO b ) as 
p. apply ( setquotunivprop _ ( fun xO hProppair _ ( int xO ) ) ). 
intros be q, destruct be as [be], assert ( afldfracapartrelpre ( 
dirprodpair b c ) ( dirprodpair ( Srngunell A ) ( unel ( 
aintdomazerosubmonoid A ) ) ) ) as is'. apply q. split with 
(setquotpr (eqrelcommrngfrac A (aintdomazerosubmonoid A)) ( 
af Idf racmultinvint ( dirprodpair be) is' ) ). 

split . change ( setquotpr ( eqrelcommrngfrac A ( 
aintdomazerosubmonoid A ) ) ( dirprodpair ( Sop2 A ( prl ( 
af Idf racmultinvint ( dirprodpair bc)is'))b)( Qop ( 
aintdomazerosubmonoid A ) ( pr2 ( af Idf racmultinvint ( dirprodpair b 
c)is'))c))*'>( commrngf racunel 2 A ( aintdomazerosubmonoid A 
) ) ) . apply iseompsetquotpr . unfold commrngf raeunel2int , destruct 
c as [ c c' ]. simpl. apply total2tohexists . split with ( 
carrierpair ( fun x : prl A=>x#0) 1 ( prl ( pr2 A ) ) ) . 
simpl. rewrite 3! ( Qrngrunax2 A ). rewrite ( Qmglunax2 A ). apply 
( Qmgcomm2 A ) . 



change ( setquotpr ( aqrelcommrngf rac A ( aintdomazerosubraonoid A ) 
) C dirprodpair ( @op2 A b ( prl ( af Idfracmultinvint ( dirprodpair b 
c ) is' ) ) ) C Qop C aintdomazerosubraonoid A ) c C pr2 ( 
af Idfracmultinvint C dirprodpair be) is '))))">( 
commrngf racunel2 A C aintdomazerosubmonoid A ) ) ) . apply 
iscompsetquotpr . destruct c as [ c c' ] , simpl. apply 
total2toliexists . split with ( carrierpair ( fun x : prl A => x # ) 
1 ( prl C pr2 A ) ) ), simpl. rewrite 3! ( Srngrunax2 A ). rewrite C 
Qmglunax2 A ). apply ( Qmgcomm2 A ). apply p. assumption. 
Defined. 

Theorem af Idf racisaf Id ; isaafield afldfracO. Proof, intros. split, 
change C ( af Idf racapartrel ) ( firngunel2 ( commingfrac A ( 



7.6 The file zmodp . V 



(** *Integers mod p *) 

(** By Alvaro Pelayo, Vladimir Voevodsky and Michael A. Warren *) 
(** December 2011 *) 

(** Settings *) 

Add Rec LoadPath "../Generalities". Add Rec LoadPath " . . /hlevell" . 

Add Rec LoadPath " . . /hlevel2" . Add Rec LoadPath 

".. /Proof _of _Extensionality" . Add Rec LoadPath "../Algebra". 

Unset Automatic Introduction. (** This line has to be removed for the 
file to compile with Coq8.2 *) 

(** Imports *) 

Require Export lemmas . 

Open Scope hz_scope. 

(** * I. Divisibility and the division algorithm *) 

Definition hzdivO : hz -> hz -> hz -> UU fun nmk=> (n*k~>m 
). 

Definition hzdiv : hz -> hz -> hProp := fun n m => hexists ( fun k : 
hz => hzdivO n m k ) . 

Lemma hzdivisrefl : isrefl ( hzdiv ). Proof, unfold 

isrefl, intro, unfold hzdiv, apply total2tohexists. split with 

1. apply hzmultrl. Defined. 

Lemma hzdivistrans : istrans ( hzdiv ). Proof. intros a b c p 

q, apply p. intro k, destruct k as t k f ] . apply q. intro 

1. destruct 1 as [ 1 g ]. intros P s. apply s. unfold hzdivO in f,g. 

split with C k * 1 ). unfold hzdivO. rewrite <- hzmultassoc. rewrite 

f . assumption. Defined . 

Lemma hzdivlinearcombleft (abcd:hz) Cf:a~>(b+c)) (x 
: hzdiv da) C y : hzdiv d b ) : hzdiv d c. Proof, intros a b c d f 
X y P s. apply x. intro x' . apply y, intro y' , destruct x' as [ k g 
]. destruct y' as [ 1 h ]. unfold hzdivO in *. apply s. split with ( 
k + - 1 ). rewrite hzldistr. rewrite g. rewrite C mgrmultminus hz 



aintdomazerosubmonoid A ) ) ) C Srngunell ( commrngf rac A ( 
aintdomazerosubmonoid A ) ) ) ). unfold af Idf racapartrel . cut ( ( 
3op2 A ( @rngunel2 A ) ( @rngunel2 A ) ) # ( 3op2 A ( Qmgunell A ) C 
@rngunel2 A ) ) ). intro v. apply v. rewrite 2! ( Qrngrunax2 A 
) . apply A . 

intros a p. apply af Idf racmultinv. assumption. Defined. 
Definition afldfrac := afldpair afldfracO af Idf racisaf Id. 
End aint. 

Close Scope rng_scope. 
(** END OF FILE *) 



). change (Ca+C-Cd*l)) )5ihz ~> c ) . rewrite h. apply ( 
hzplusrcan _ _ b ). rewrite hzplusassoc. rewrite hzlminus. rewrite 
hzplusrO . rewrite hzpluscomm . assumpt ion . Def ined . 

Lemma hzdivlinearcombright Cabcd:hz)Cf:a~>Cb+c))Cx 
: hzdiv d b ) C y : hzdiv d c ) : hzdiv d a. Proof. intros a b c d f 
X y P s, apply x, intro x'. apply y. intro y' . destruct x' as [kg 
]. destruct y' as [ 1 h ], imfold hzdivO in *. apply s, split with C 
k + 1 ). rewrite hzldistr. change ( (d * k + d * l)%hz ~> a 
). rewrite g, h, f. apply idpath. Defined. 

Lemma divalgorithmnonneg C n : nat ) ( m : nat ) C p : hzlth C 
nattohz m ) ) : total2 ( fun qr : dirprod hz hz => ( ( dirprod ( 
nattohz n ~> ( ( ( nattohz m ) * ( prl qr ) ) + ( pr2 qr ) ) ) ( 
dirprod C hzleh C pr2 qr ) ) C hzlth C pr2 qr ) ( nattohz Cm))) 
) ) ) ). Proof. intro. intro. induction n. intros. split with ( 
dirprodpair 0). split, simpl. rewrite C rngrunaxl hz ). rewrite C 
rngmultxO hz ) . rewrite nattohzandO. change ( ~> O'^^hz ) . apply 
idpath. split . apply isref Ihzleh. assumption. 

intro p, set ( q' := prl ( prl ( IHn p ) ) ). set C r' pr2 C 
prl C IHn p ) ) ), set C f := prl C pr2 ( IHn p ) ) ). assert ( 
hzleh C r' + 1 ) C nattohz m ) ) as p'. assert ( hzlth ( r' + 1 ) 
C nattohz m + 1 ) ) as p''. apply hzlthandplusr . apply ( pr2 ( 
pr2 C pr2 ( IHn p ) ) ) ), apply hzlthsntoleh, assumption. set ( 
choice := hzlehchoice ( r' + 1 ) ( nattohz m ) p' ), destruct 
choice as [ k I h ] . split with ( dirprodpair q' ( r' + 1 ) 
) . split, rewrite (nattohzandS _ ) . rewrite hzpluscomm.. rewrite 
f. change C nattohz m * q' + r' + 1 ~> C nattohz m * q' + ( r' + 1 
) ) ). apply rngassocl. split, apply ( istranshzleh Or' ( r' + 1 
) ), apply C C pr2 ( pr2 ( IHn p ) ) ) ). apply hzlthtoleh. apply 
hzlthnsn. assumption. split with ( dirprodpair ( q' + 1 ) 
). split, rewrite C nattohzandS _ ). rewrite hzpluscomm. rewrite 
f. change ( nattohz m*q'+r'+l''>C nattohz m*Cq*+l) + 
) ). rewrite ( hzplusassoc ). rewrite h, rewrite C mgldistr _ 
q' _ ) . rewrite rngrunax2 . rewrite hzplusrO . apply idpath. 
split . apply isref Ihzleh. assumption. Defined. 

C* A test of the division algorithm for non-negative integers: Lemma 
testlemmal : ( hzneq 0(1)). Proof , change with C nattohz Oyinat 
). rewrite <- nattohzandl. apply nattohzandneq. intro f. apply C 
isirref Inatlth 1 ). assert C natlth 1) as i, apply 
natlthnsn. rewrite <- f in *. assumption. Defined. 



Lemma testlemma2 : { hzneq 0(1+1) ). Proof. change with ( 
nattohz 07jiat ) . rewrite <- nattohzandl . rewrite <- 

nattohzandplus . apply nattohzandneq. assert ( natneq Cl+l)0)as 
z. apply ( natgthtoneq (1+1)0). simpl. auto, intro f. apply 
X. apply pathsinvO. assumption. Defined. 

Lemma testlemma21 : hzlth ( nattohz 2 ). Proof, change with ( 
nattohz 0%nat ). apply nattohzandlth . apply ( istransnatlth _ 1 
). apply natlthnsn. apply natlthnsn. Defined. 

Lemma testlemmaS : hzlth C nattohz 3 ). Proof, apply ( 
istranshzlth _ ( nattohz 2 ) ). apply tsstlemma21, change with ( 
nattohz 07,nat ), apply nattohzandlth. apply natlthnsn. Defined. 

Lemma testlemmaS : hzlth ( nattohz 9 ), Proof, apply ( 

istranshzlth _ ( nattohz 3 ) ). apply testlemma3. apply ( 

istranshzlth _ ( nattohz 6 ) ). apply testleiimia3. apply testleiimia3. 

Defined, 



Eval lazy in hzabsval C prl { prl ( divalgorithmnonneg 1(1+1) 
testlerama21 ) ) ) . Eval lazy in hzabsval ( prl ( prl ( 
divalgorithmnonneg (5) (1+1) testlemma21 ) ) ) . Eval lazy in 
hzabsval ( pr2 ( prl ( divalgorithmnonneg (5) (1+1) testlemma21 
) ) ) . Eval lazy in hzabsval C prl ( prl ( divalgorithmnonneg 16 3 
testlemmaS ) ) ) . Eval lazy in hzabsval ( pr2 ( prl ( 
divalgorithmnonneg 16 3 testlemmaS ) ) ) . Eval lazy in hzabsval ( prl 
( prl ( divalgorithmnonneg 18 9 testlemma9 ) ) ) . Eval lazy in 
hzabsval ( pr2 ( prl ( divalgorithmnonneg 18 9 testlemma9 ) ) ) . *) 

Theorem divalgorithmexists ( n m : hz ) C p : hzneq m ) : total2 ( 
fun qr : dirprod hz hz => ( ( dirprod (n~>((m*( prl qr ) ) + ( 
pr2 qr ) ) ) ( dirprod ( hzleh ( pr2 qr ) ) ( hzlth ( pr2 qr ) ( 
nattohz ( hzabsval m)) ))))). Proof. intros. destruct ( 
hzlthorgeh n ) as [ n_neg I n_nonneg ] . destruct ( hzlthorgeh m ) 
as [ m_neg I m_nonneg ] . 

C*Case I: n<0, m<0:*) set ( n' := hzabsval n ). set ( m' := hzabsval 
m ). assert ( nattohz m' ~> ( - m ) ) as f. apply 
hzabsvallthO . assumption. assert ( - - n ~> - ( nattohz n' ) ) as 
fO. rewrite <- ( hzabsvallthO n_neg ). rewrite ( hzabsvallthO n_neg 
). unfold n' . rewrite ( hzabsvallthO n_neg ). apply idpath. assert 
( hzlth ( nattohz m* ) ) as p' . assert { hzlth OC-m))asq. 
apply hzlthOandminus . assumption, rewrite f. assumption. set ( a : = 
divalgorithmnonneg n' m' p' ). set C q := prl ( prl a ) ). set C r 
: = pr2 ( prl a ) ) . set ( Q : = q + 1 ) . set ( R : = - m - r ) . 

destruct ( hzlehchoice r ( prl ( pr2 ( pr2 a ) ) )) as [ less I 
equal ]. split with ( dirprodpair Q R ), split. 

rewrite ( pathsinvO( rngminusminus hz n) ). assert ( - nattohz n' 
~> ( m * Q + R ) ) as fl. unfold Q. unfold R. rewrite ( prl ( ( 
pr2 a ) ) ). change ( prl ( prl a ) ) with q. change ( pr2 ( prl 
a ) ) with r. rewrite hzaddinvplus . rewrite <- ( rnglmultminus hz 
). rewrite f. rewrite ( rngminusminus ). rewrite ( mgldistr _ q 
_ _ ) . rewrite C hzmultrl ) . change C Cm*q)+-r~>( Cm*q 
+m)+(-m+-r))). rewrite ( hzplusassoc ) . rewrite <- ( 
hzplusassoc m _ _ ) . change ( m + - m ) with ( m - m ) , rewrite ( 
hzrminus ) . rewrite ( hzpluslO ) . apply idpath, exact ( 
pathscompO fO fl ). split, unfold R. assert ( hzlth r ( - m ) ) 
as u. rewrite <- hzabsvallehO . apply C pr2 ( pr2 ( pr2 C a ) ) ) 
). apply hzlthtoleh. assumption, rewrite <- ( hzlminus m ). change 
( pr2 ( dirprodpair Q(-m-r))) with ( - m - r ) . apply 
hzlehandplusl , apply hzlthtoleh, rewrite <- ( rngminusminus hz m 
). apply hzlthminusswap . assimiption. imfold R, unfold m' . rewrite 
hzabsvallehO . change ( hzlth (-m+-r) (-m) ). assert C 
hzlth C-m-r) (-m+0))asu. apply hzlthandplusl . apply 



hzgthOandminus . apply less, assert (-m+0~> (-m) ) asf. 
apply hzplusrO, exact ( transportf ( fun x : _ => hzlth ( - m + - 
r ) X ) f u ). apply hzlthtoleh. assumption. split with 
(dirprodpair q ). split, rewrite <- ( rngminusminus hz n ) . 
assert ( - nattohz n' "> ( m * q + ) ) as fl. rewrite ( prl ( 
pr2 (a ) ) ) . change C prl (prl a ) ) with q. change ( pr2 C prl 
a ) ) with r, rewrite hzplusrO. rewrite ( pathsinvO equal 
) . rewrite ( hzplusrO ) . assert ( - ( nattohz m'*q) ">((-( 
nattohz m' ) ) * q ) ) as f2. apply pathsinvO, apply 
rnglmultminus. rewrite f2. unfold m' . rewrite hzabsvallehO, apply 
C maponpaths C fun x:_=>x*q)), apply rngminusminus . apply 
hzlthtoleh. assumption, exact ( pathscompO fO fl ). split, change 
( pr2 ( dirprodpair q ) ) with 0. apply ( Isreflhzleh ). rewrite 
equal . change ( pr2 ( dirprodpair q r ) ) with r . apply C pr2 ( 
pr2 ( pr2 ( a ) ) ) ). 

destruct C hzgehchoice m m_nonneg ) as [ h I k ] . 
(*====*) 

C*Case II: n<0, m>0. *) 

assert ( hzlth ( nattohz ( hzabsval m ) ) ) as p' , rewrite ( 
hzabsvalgthO ). apply h. assumption. set C a := 
divalgorithmnonneg ( hzabsval n ) ( hzabsval m ) p' ). set ( q' 
:= prl ( prl a ) ). set ( r' ;= pr2 ( prl a ) ), assert ( n ~> - 
- n ) as fO. apply pathsinvO, apply rngminusminus, assert ( - - n 
~> - ( nattohz ( hzabsval n ) ) ) as fl. apply pathsinvO. apply 
maponpaths. apply ( hzabsvallehO ). apply hzlthtoleh. assumption, 
destruct C hzlehchoice r' ( prl C pr2 C pr2 Ca)))))as[ 
less I equal ] . split with (dirprodpair (-q'-l) (m-r') 
). split, change ( prl ( dirprodpair (-q'-l) (m-r'))) 
with ( - q' - 1 ) . change ( pr2 ( dirprodpair (-q' -1) (m- 
r' ) ) ) with (m-r' ). change ( - q' - 1 ) with ( - q' + C - 
l°/,hz ) ), rewrite hzldistr, assert ( - nattohz ( hzabsval n ) "> 
((m*(-q')+m*( - I'/Jiz ) ) + ( m - r' ) ) ) as f2. 
rewrite ( prl ( pr2 ( a ) ) ) . change ( prl C prl a ) ) with 
q' . change ( pr2 ( prl a ) ) with r' . rewrite 

hzabsvalgthO. rewrite hzaddinvplus. rewrite ( rngrraultminus hz ), 
rewrite ( hzplusassoc _ ( m * ( - l°/,hz ) ) _ ) . apply ( maponpaths 
C fun X :_=>- (m*q' )+x) ). assert (-m+ (m-r' ) ~> 
C m * ( - iVthz ) + (m-r')))asf3. apply C maponpaths C fun 
x : _=>x+ Cm-r' ) ) ). apply pathsinvO. assert ( m * ( - 
l°/,hz ) ~> ( - ( m * l%hz ) ) ) as f30. apply ( rngrmultminus 
). assert (-(m*l)~>-m)as f31. rewrite hzmultrl. apply 
idpath. rewrite f30. assumption. assert (-r' ~>(-m+(m- 
r' ) ) ) as f4. change C-r' ~> (-m+ Cm+-r' ) ) ). rewrite 
<- C hzplusassoc ) . rewrite C hzlminus ) , C hzpluslO ) . apply 
idpath. rewrite f4. assumption, assumption, rewrite fO, 
f 1 . assumption. 

split, change ( pr2 ( dirprodpair (-q'-l) (m-r'))) with 
(m-r' ). apply hzlthtoleh. rewrite <- ( hzrminus r' ), apply 
hzlthandplusr . rewrite <- ( hzabsvalgehO m_nonneg ) , apply ( pr2 
C pr2 C a ) ) ) . rewrite C hzabsvalgehO m_nonneg ) , assert ( 
hzlth (m-r' ) (m+0) ) asu. apply ( hzlthandplusl ). apply 
( hzgthOandminus ) . apply less . rewrite hzplusrO in 
u. assumption. 

split with ( dirprodpair ( - q' ) ). split, change ( prl ( 
dirprodpair ( - q' ) ) ) with ( - q* ) . change ( pr2 ( 
dirprodpair ( - q' ) ) ) with 0, assert ( - nattohz ( hzabsval 
n ) "> ( m * - q' + ) ) as f2. rewrite ( hzplusrO ). rewrite ( 
prl ( pr2 ( a ) ) ) . change ( prl ( prl a ) ) with q' , change ( 
pr2 ( prl a ) ) with r' . rewrite <- equal, rewrite 
hzplusrO. rewrite hzabsvalgehO. apply pathsinvO. apply 



mgrmultminus , assumption . rewrite f , 

f 1 . assumption, split . apply ( isref Ihzleh ) , rewrite equal . apply 
( pr2 C pr2 C pr2 ( a ) ) ) ) . 

assert empty, apply p. apply pathsinvO. 
assumption, contradiction. 

set ( choice2 := hzlthorgeh m ). destruct choice2 as [ m_neg I 
m_nomieg ] . 

(mCase III. Assume n>=0, m<0:>K) assert ( hzlth ( nattohz ( hzabsval 
m ) ) ) as p' . rewrite C hzabsvallthO ). rewrite <- C 

rngminusminus hz m ) in m_neg. set ( d:= hzlthOandminus m_neg 
). rewrite rngminusminus in d. apply d. assumption. set C a 
divalgorithmnonneg ( hzabsval n ) ( hzabsval m ) p' ). set ( q' 
:= prl C prl a ) )- set C r' := pr2 ( prl a ) ). split with ( 
dirprodpair ( - q' ) r* ). split, rewrite <- ( hzabsvalgehO ). 
rewrite C prl ( pr2 ( a ) ) ) . change ( prl C prl a ) ) with 
q' . change { pr2 C prl a ) ) with r' . change { prl ( dirprodpair 
C - q' ) r' ) ) with C - q' ). change C pr2 { dirprodpair { - q' 
) r' ) ) with r' . rewrite ( hzabsvallehO ). apply C maponpaths C 
fun X : ^ X + r' ) ). assert ( - m * q' ~> - { m * q' ) ) as 
fO. apply rnglmultminus . assert C-(m*q' ) ~>m*(-q' ) ) 
as fl. apply pathsinvO. apply mgrmultminus. exact ( pathscompO fO 
fl ) . apply hzlthtoleh. assumption, assumption. split, apply ( 
prl C pr2 C pr2 ( a ) ) ) ). apply C pr2 C pr2 ( pr2 ( a ) ) ) ) . 

(♦Case IV: n>=0, m>0.*) 

assert ( hzlth ( nattohz ( hzabsval m ) ) ) as p' . rewrite C 

hzabsvalgehO ). destruct ( hzneqchoice Om) as [1 I r]. apply 
p. assert empty, apply ( isirref Ihzgth ) . apply ( hzgthgehtrans 
ra ). assumption, assumption, contradiction. 

assumption, assumption. set ( a := divalgorithmnonneg C hzabsval 
n ) C hzabsval ra ) p' ). set ( q* := prl C prl a ) ). set C r' := 
pr2 C prl a ) ). split with { dirprodpair q' r' ). split, 
rewrite <- hzabsvalgehO. rewrite ( prl ( pr2 C a ) ) ). change { 
prl C prl a ) ) with q' . change { pr2 { prl a ) ) with r' . change 
( prl C dirprodpair q' r' ) ) with q' . change { pr2 C dirprodpair 
q' r' ) ) with r' . rewrite hzabsvalgehO. apply 

idpath. assumption, assumption. split, apply ( prl ( pr2 ( pr2 ( 
a ) ) ) ). apply ( pr2 ( pr2 ( pr2 ( a ) ) ) ). Defined. 

Lemma hzdivhzabsval ( a b ; hz ) ( p : hzdiv a b ) ; hdisj ( natleh C 
hzabsval a ) ( hzabsval b ) ) ( hzabsval b ~> 0°/,nat ). Proof. intros 
a b p P q. apply ( p P ). intro t. destruct t as [ k f ]. unfold 
hzdivO in f. apply q. apply natdivleh with { hzabsval k ). rewrite ( 
hzabsval andmult ) . rewrite f . apply idpath. Defined. 

Lemma divalgorithm { n m : hz ) ( p : hzneq ra ) : iscontr C total2 C 
fun qr : dirprod hz hz C { dirprod Cn~>(Cra*C prl qr ) ) + C 
pr2 qr ) ) ) C dirprod ( hzleh ( pr2 qr ) ) ( hzlth ( pr2 qr ) ( 
nattohz ( hzabsval ra)))))))). Proof. intros. split with ( 
divalgorlthmexists n m p ). intro t. destruct t as [ qr' t' 
]. destruct qr* as [ q' r' ]. simpl in t'. destruct t* as [ f * p2p2t 
] . destruct p2p2t as [ plp2p2t p2p2p2t ] . destruct divalgorithmexists 
as [ qr V ] . destruct qr as [ q r ] . destruct v as [ f p2p2dae ] . 
destruct p2p2dae as [ plp2p2dae p2p2p2dae ] . simpl in f . simpl in 
plp2p2dae. simpl in p2p2p2dae. 

assert ( r' "> r ) as h. C*Proof that r' ~> r :*) assert ( m * C q 
- q' ) ~> C r' - r ) ) as hO. change ( q - q' ) with C q + - q' 
). rewrite ( hzldistr ), rewrite <- ( hzplusrO { r' - r ) 
). rewrite <- ( hzrminus ( m * q' ) ). change ( r' - r ) with ( r' 
+ ( - r ) ). rewrite ( hzplusassoc r' ). change (Cm*q')-Cm 
* q' ) ) with C(m*q')+(-(m*q'))). rewrite <- ( 



hzplusassoc C - r ) ). rewrite ( hzpluscomm ( -r ) ). rewrite <- C 
hzplusassoc r' ) . rewrite <- ( hzplusassoc r' ) . rewrite ( 
hzpluscoumi r' ). rewrite <- f. rewrite f. rewrite ( hzplusassoc C 
m * q ) ) . change C r + - r ) with ( r - r ) . rewrite ( hzrminus ) . 
rewrite ( hzplusrO ) . rewrite C mgrmultminus hz ) . change ( m * q 
+ -(m*q')) with (Cm*q + -Cm*q') )°/,mg ). apply 
idpath . 

assert ( hdisj C natleh ( hzabsval ra ) ( hzabsval Cr'-r)))C 
hzabsval ( r' - r ) ~> O'/oiat ) ) as v. apply hzdivhzabsval. intro 
P. intro s. apply s. split with C q - q' ). unfold 
hzdivO. assumption, assert ( isaprop ( r' ~> r ) ) as P. apply ( 
isasethz ). apply ( v ( hProppair ( r' "> r ) P ) ). intro 
s. destruct s as [ left I right ]. assert { hzlth ( nattohz ( 
hzabsval (r' -r) ) ) ( nattohz ( hzabsval m ) ) ) as u. 
destmct C hzgthorleh r' r ) as [ greater I lesseq ] . assert ( 
hzlth (r* -r) ) ase. rewrite <- ( hzrminus r ). apply 
hzlthandplusr . assumption, rewrite ( hzabsvalgthO ) . apply 
hzlthminus. apply ( p2p2p2t ). apply ( p2p2p2dae ). apply C 
plp2p2dae ), apply e. destruct C hzlehchoice r' r lesseq ) as [ 
less I equal ] , rewrite hzabsvalandminuspos . rewrite 
hzabsvalgthO, apply hzlthminus. apply ( p2p2p2dae ). apply C 
p2p2p2t ). apply ( plp2p2t) . apply hzlthminusequiv. 
assumption, apply C plp2p2t ). apply plp2p2dae. rewrite 
equal, rewrite hzrminus. rewrite hzabsvalO. rewrite 
nattohzandO. apply hzabsvalneqO. intro Q. apply p. assumption, 
assert empty, apply ( isirref Ihzlth ( nattohz ( hzabsval m ) ) ). 
apply C hzlehlthtrans _ ( nattohz ( hzabsval Cr'-r)))_). 
apply nattohzandleh. assumption, assumption, contradiction, 
assert ( r' ~> r ) as i. assert ( r' - r ~> ) as iO. apply 
hzabsvaleqO. assumption, rewrite <- ( hzpluslO r ). rewrite <- C 
hzplusrO r' ). assert (r' +(r-r) ~> (O+r) ) as iOO. 
change C r - r ) with ( r + - r ) . rewrite ( hzpluscomm _ C - r ) 
). rewrite <- hzplusassoc, apply C maponpaths C fun x : _ => x + 
r ) ). apply iO, exact C transportf C fun x:_=>Cr'+x~>C 
+ r ) ) ) C ( hzrminus r ) ) iOO ) . apply i . 

assert ( q' "> q ) as g. C* Proof that q' ~> q:*) rewrite h in 
f. rewrite f in f. apply C hzmultlcan q' q m ). intro i. apply 
p. apply pathsinvO. assumption. apply ( hzplusrcan Cm*q' ) (m* 
q ) r ). apply pathsinvO. apply f. 

(* Path in direct product: *) assert ( dirprodpair q' r' "> ( 
dirprodpair q r ) ) as j . apply 
pathsdi rprod . assumption, assumption. 

(* Proof of general path: *) apply pathintotalf iber with C pO := j 
) . assert ( iscontr ( dirprod Cn~> Cm*q+r) ) C dirprod ( 
hzleh r ) ( hzlth r C nattohz ( hzabsval m))))))as 
contract. change iscontr with ( isofhlevel ) . apply 
isof hlevGldirprod. split with f. intro t. apply isasethz. apply 
isofhleveldirprod. split with plp2p2dae. intro t. apply hzleh. 
split with p2p2p2dae. intro t. apply hzlth. apply 
proof irrelevancecontr . assumption. Defined. 

Definition hzquotientmod ( p : hz ) ( x : hzneq Op) : hz -> hz := 
fun n ; hz => ( prl ( prl ( divalgorithmexists n p x ) ) ) . 

Definition hzremaindermod ( p : hz ) C x : hzneq Op) : hz -> hz := 
fun n : hz => C pr2 ( prl ( divalgorithmexists n p x ) ) ) . 

Definition hzdivequationmod ( p : hz ) ( x : hzneq Op) C n : hz ) : 
n "> ( p * C hzquotientmod p x n ) + ( hzremaindermod p x n ) ) := ( 
prl ( pr2 C divalgorithmexists n p x ) ) ) . 



Definition hzlehOremaindermod ( p : hz ) ( x : hzneq Op) ( n : hz ) 



: hzleh { hzremaindermod p x n ) := ( prl ( pr2 ( pr2 ( 
divalgorithmexists n p x ) ) ) ) . 

Definition hzlthremaindermodmod ( p : hz ) C x ; hzneq Op) ( n : hz 
) : hzlth C hzremaindermod p x n ) ( nattohz ( hzabsval p ) ) := C pr2 
( pr2 C pr2 ( divalgorithmexists n p x ) ) ) ) . 

C* Eval lazy in hzabsval C ( ( hzquotientmod { 1 + 1 ) testleimna2 { 1 
+1+1+1+1+1+1+1) ) ) ). Eval lazy in hzabsval C ( ( 
hzremaindermod ( 1 + 1 ) testlemma2 (1+1+1+1+1+1+1+1+ 
1 ) ) ) ). *) 

C** * II. QUOTIENTS AND REMAINDERS *) 

Definition isaprime ( p : hz ) : UU := dirprod ( hzlth 1 p ) ( forall 
m : hz, ( hzdiv m p ) -> ( hdisj Cm~>l)(m~>p))). 

Lemma isapropisaprime C p : hz ) : isaprop C isaprime p ). Proof, 
intros, apply isof hleveldirprod. apply ( hzlth 1 p ). apply 
impred, intro m, apply impredfun, apply C hdisj {m~>l) Cm~>p) 
), Defined, 

Lemma isaprimetoneqO { p : hz } ( x : isaprime p ) : hzneq p. 
Proof, intros. intros f . apply C isirref Ihzlth ) . apply ( 
istranshzlth _ 1 _ ). apply hzlthnsn. rewrite f. apply C prl x ). 
Defined, 

Lemma hzqrtest ( m : hz ) C x : hzneq Om) (aqrihz) : dirprod ( 
a~>(Cm*q)+r))( dirprod ( hzleh r ) ( hzlth r ( nattohz 
(hzabsval m ) ) ) ) -> dirprod ( q "> hzquotientmod m x a ) ( r "> 
hzremaindermod m x a ). Proof. intros ra x a q r d. set ( k := tpair 
( P := ( fun qr : dirprod hz hz dirprod ( a ~> ( m * ( prl qr ) + 
pr2 qr ) ) ( dirprod ( hzleh ( pr2 qr ) ) ( hzlth ( pr2 qr ) ( 
nattohz ( hzabsval m)))))) ( dirprodpair q r ) d ) . assert ( k 
~> ( prl ( divalgorithm amx) ) ) asf. apply ( pr2 ( divalgorithm 
a m X ) ). split, change q with ( prl ( prl k ) ). rewrite f . apply 
idpath. change r with ( pr2 ( prl k ) ). rewrite f. apply idpath. 
Defined. 

Definition hzqrtestq ( m : hz ) ( x : hzneq Om) (aqr:hz) (d; 
dirprod (a~>((m*q)+r))( dirprod ( hzleh r ) ( hzlth r ( 
nattohz (hzabsval m ) ) ) ) ) : = prl ( hzqrtest m x a q r d ) . 

Definition hzqrtestr ( m ; hz ) ( x : hzneq Ora)(aqr:hz)(d: 
dirprod Ca~>((m*q)+r))( dirprod ( hzleh r ) ( hzlth r ( 
nattohz (hzabsval m ) ) ) ) ) := pr2 ( hzqrtest m x a q r d ), 

Lemma hzqrandOeq ( p : hz ) ( x : hzneq Op) :0~>((p*0)+0 
). Proof, intros. rewrite hzmultxO. rewrite hzpluslO. apply idpath. 
Defined. 

Lemma hzqrandOineq ( p : hz ) ( x : hzneq Op); dirprod ( hzleh 

) ( hzlth ( nattohz ( hzabsval p ) ) ) . Proof . 

intros . split . apply isref Ihzleh. apply hzabsvalneqO . assumption. 

Defined. 

Lemma hzqrandOq ( p : hz ) ( x ; hzneq Op): hzquotientmod p x ~> 
0, Proof, intros, apply pathsinvO, apply ( hzqrtestq p x ). 
split, apply ( hzqrandOeq p x ). apply ( hzqrandOineq p x ). Defined. 

Lemma hzqrandOr ( p : hz ) ( x : hzneq Op): hzremaindermod p x "> 
0. Proof, intros. apply pathsinvO. apply ( hzqrtestr p x ). 
split, apply ( hzqrandOeq p x ). apply ( hzqrandOineq p x ). Defined. 

Lemma hzqrandleq ( p : hz ) ( is : isaprime p) : l~>((p*0)+l 
). Proof, intros. rewrite hzmultxO. rewrite hzpluslO. apply idpath. 



Defined. 



Lemma hzqrandlineq ( p : hz ) ( is : isaprime p ) : dirprod ( hzleh 
1 ) C hzlth 1 C nattohz ( hzabsval p ) ) ) . Proof . 
intros. split, apply hzlthtoleh. apply hzlthnsn. rewrite C 
hzabsvalgthO ). apply is. apply ( Istranshzgth _ 1 _ ). apply 
is. apply ( hzgthsnn ), Defined. 

Lemma hzqrandlq ( p : hz ) ( is : isaprime p ) : hzquotientmod p ( 
isaprimetoneqO is ) 1 ~> 0. Proof. intros. apply pathsinvO. apply ( 
hzqrtestq p ( isaprimetoneqO is ) 10 1). split, apply C hzqrandleq 
p is ) . apply ( hzqrandlineq p is ) . Defined. 

Lenmia hzqrandlr ( p : hz ) ( is : isaprime p ) : hzremaindermod p ( 
isaprimetoneqO is ) 1 ~> 1 . Proof . intros . apply pathsinvO. apply ( 
hzqrtestr p ( isaprimetoneqO is ) 10 1). split, apply C hzqrandleq 
p is ) . apply C hzqrandlineq p is ) . Defined. 

Lemma hzqrandself eq ( p : hz ) C x : hzneq Op) :p~>(p*l+0). 
Proof . intros . rewrite hzmultrl , rewrite hzplusrO , apply idpath. 
Defined . 

Lemma hzqrandself ineq ( p : hz ) C x : hzneq Op): dirprod ( hzleh 
) C hzlth C nattohz ( hzabsval p ) ) ). Proof, split, apply 
isref Ihzleh. apply hzabsvalneqO , assumption. Defined. 

Lemma hzqrandselfq ( p : hz ) C x : hzneq Op): hzquotientmod p x p 
~> 1. Proof. intros. apply pathsinvO. apply ( hzqrtestq p x p 1 
). split, apply C hzqrandself eq p x ). apply ( hzqrandself ineq p x ). 
Defined. 

Lemma hzqrandselfr ( p : hz ) ( x : hzneq Op): hzremaindermod p x p 
~> 0. Proof. intros. apply pathsinvO. apply ( hzqrtestr p x p 1 
). split, apply ( hzqrandself eq p x ). apply ( hzqrandself ineq p x ). 
Defined. 

Lemma hzqrandpluseq ( p : hz ) C x : hzneq Op) (ac:hz) : (a+ 
c)~>(Cp*( hzquotientmod p x a + hzquotientmod p x c + 
hzquotientmod p x ( hzremaindermod p x a + hzremaindermod p x c ) ) ) 
+ hzremaindermod p x ( ( hzremaindermod p x a ) + ( hzremaindermod p x 
c ) ) ). Proof. intros. rewrite 2! ( hzldistr ). rewrite ( 
hzplusassoc ) . rewrite <- C hzdivequationmod p x ( hzremaindermod p x 
a + hzremaindermod p x c ) ). rewrite hzplusassoc. rewrite C 
hzpluscomm ( hzremaindermod p x a ) ) , rewrite <- ( hzplusassoc ( p * 
hzquotientmod p x c ) ) . rewrite <- ( hzdivequationmod p x c 
). rewrite ( hzpluscomm c ). rewrite <- hzplusassoc. rewrite <- ( 
hzdivequationmod p x a ). apply idpath. Defined. 

Lemma hzqrandplusineq ( p : hz ) ( x : hzneq Op) (ac:hz) : 
dirprod ( hzleh C hzremaindermod p x ( hzremaindermod p x a + 
hzremaindermod p x c ) ) ) ( hzlth ( hzremaindermod p x ( 
hzremaindermod p x a + hzremaindermod p x c ) ) C nattohz ( hzabsval p 
) ) ) . Proof. intros, split, apply hzlehOremaindermod . apply 
hzlthremaindermodmod , Def ined , 

Lemma hzremaindermodandplus ( p : hz ) C x : hzneq Op) (ac:hz) 
: hzremaindermod pxCa+c) ~> hzremaindermod p x ( hzremaindermod 
p X a + hzremaindermod p x c ), Proof, intros, apply 
pathsinvO. apply ( hzqrtest px(a+c)__( dirprodpair ( 
hzqrandpluseq p x a c ) ( hzqrandplusineq p x a c ) ) ). Defined. 

Lemma hzquotientmodandplus ( p : hz ) ( x : hzneq Op) Cac:hz) : 
hzquotientmod px(a+c)~>C hzquotientmod p x a + hzquotientmod p 
X c + hzquotientmod p x ( hzremaindermod p x a + hzremaindermod p x c 
) ). Proof, intros. apply pathsinvO. apply ( hzqrtest p x C a + c ) 
_ _ C dirprodpair C hzqrandpluseq p x a c ) C hzqrandplusineq p x a c 



) ) ). Defined. 

Lemma hzqraad'time&eq ( m : hz ) ( x : hzneq Om) (ab :hz) : (a* 
b)"'>C(m*C( hzquotientmod m x ) a * ( hzquotientmod m z ) b * m 
+ (hzremalndermod m x b ) * ( hzquotientmod m x a ) + ( hzremaindenaod 
m X a ) * C hzquotientmod m x b ) + C hzquotientmod m x ( 
hzremaindermod m x a * hzremaindermod mxb) ) ) ) + hzremaindermod m 
X ( hzremaindermod m x a * hzremaindermod mxb) ) . Proof . 
intros, rewrite 3! ( hzldistr ). rewrite ( hzplusassoc _ _ C 
hzremaindermod m x ( hzremaindermod m x a « hzremaindermod mxb)) 
). rewrite <- hzdivequationmod. rewrite C hzmultassoc _ _ m 
) . rewrite <- ( hzmultassoc m _ C hzquotientmod m x b * m ) ) . rewrite 
C hzmultcomm _ m ). change ( (Cm * hzquotientmod m x a * (m * 
hzquotientmod m x b))%hz + m * (hzremaindermod mxb* hzquotientmod m 
X a)'/Jiz)'/,rng ) with ((m * hzquotientmod m x a * (m * hzquotientmod m x 
b)) ■«- m »< (hzremaindermod mxb* hzquotientmod m x a) }%hz. change ( 
a * b ~> (((m * hzquotientmod m x a * (m * hzquotientmod mxb) + m * 
(hzremaindermod mxb* hzquotientmod m x a))'/,hz + m * (hzremaindermod 
m X a * hzquotientmod m x b)7,hz)7,rng + hzremaindermod m x a * 
hzremaindermod mxb)) with (a*b~>(((m* hzquotientmod m x a * 
(m * hzquotientmod mxb) + m * (hzremaindermod mxb* hzquotientmod 
m X a) ) + m * (hzremaindermod m x a * hzquotientmod m x b))%hz + 
hzremaindermod m x a * hzremaindermod mxb) ) . rewrite ( hzplusassoc 
( m * hzquotientmod m z a * ( m * hzquotientmod m x b ) ) _ _ 
) . rewrite ( hzpluscomm ( m * ( hzremaindermod mxb* hzquotientmod m 
xa))(m*( hzremaindermod m x a ♦ hzquotientmod mxb) ) ) . 
rewrite <- ( hzmultassoc m ( hzremaindermod m x a ) ( hzquotientmod m 
X b ) ) . rewrite ( hzmultcomm m ( hzremaindermod m x a ) ) . rewrite 
( hzmultassoc ( hzremaindermod m x a ) m ( hzquotientmod mxb) ) . 
rewrite <- ( hzplusassoc ( m * hzquotientmod m x a * ( m * 
hzquotientmod mxb) ) ( hzremaindermod m x a * ( m * hzquotientmod m 
X b ) ) _ ) . rewrite <- ( hzrdistr) . rewrite <- 
hzdivequationmod. rewrite hzplusassoc. rewrite ( hzmultconun ( 
hzremaindermod m x b ) ( hzquotientmod m x a ) ) . rewrite <- ( 
hzmultassoc m ( hzquotientmod m x a ) ( hzremaindermod mxb) ) . 
rewrite <- ( hzrdistr ). rewrite <- hzdivequationmod. rewrite <- 
hzldistr. rewrite <- hzdivequationmod. apply idpath. Defined. 

Lemma hzqrandtimesineq ( m : hz ) ( x ; hzneq Om) (ab:hz) : 
dirprod ( hzleh ( hzremaindermod m x ( hzremaindermod m x a * 
hzremaindermod m x b ) ) ) ( hzlth ( hzremaindermod m x ( 
hzremaindermod m x a * hzremaindermod mxb) ) ( nattohz ( hzabsval m 
) ) ) . Proof . intros . split . apply hzlehOremaindermod. apply 
hzlthremaindermodmod , Defined . 

Lemma hzquotientmodandtimes ( m : hz ) ( x : hzneq Om)(ab:hz) 
: hzquotientmod mx(a*b)~>(( hzquotientmod m x ) a * ( 
hzquotientmod m x ) b * m + (hzremaindermod mxb) * ( hzquotientmod 
m X a ) + ( hzremaindermod m x a ) * ( hzquotientmod m x b ) + ( 
hzquotientmod m x ( hzremaindermod m x a * hzremaindermod mxb) ) ) . 
Proof. intros. apply pathsinvO. apply ( hzqrtestq mx(a*b)_( 
hzremaindermod m x ( hzremaindermod m x a * hzremaindermod mxb)) 
). split, apply hzqrandtimeseq. apply hzqrandtimesineq. Defined. 

Lemma hzremaindermodandtimes ( m : hz ) ( x : hzneq Om) (ab:hz) 
: hzremaindermod mx(a*b) ~> ( hzremaindermod m x ( 
hzremaindermod m x a * hzremaindermod mxb) ) . Proof . 
intros, apply pathsinvO, apply ( hzqrtestr mx(a*b) (( 
hzquotientmod m x ) a * ( hzquotientmod m x ) b * m + (hzremaindermod 
mxb) * ( hzquotientmod m x a ) + ( hzZ'emaindermod m x a ) * ( 
hzquotientmod mxb) + ( hzquotientmod m x ( hzremaindermod m x a * 
hzremaindermod mxb) ) ) _). split, apply hzqrandtimeseq. apply 
hzqrandt ime s ineq . Def ined . 

Lemma hzqrandremaindereq ( m : hz ) (is : hzneq Om) (n:hz) : ( 



hzremaindermod misn~>((m*( prl ( dirprodpair ( 
hzremaindermod misn)))+( pr2 ( dirprodpair (Qrngunell hz ) ( 
hzremaindermod misn) ) ) ) ) ). Proof . intros . simpl . rewrite 
hzmultxO . rewrite hzpluslO . apply idpath . Defined . 

Lemma hzqrajidremainderineq ( m : hz ) ( is : hzneq m ) ( n : hz ) : 
dirprod ( hzleh ( Srngunell hz ) ( hzremaindermod m is n ) ) ( hzlth ( 
hzremaindermod m is n ) ( nattohz ( hzabsval m ) ) ). Proof, 
intros. split, apply hzlehOremaindermod. apply hzlthremaindermodmod. 
Defined. 

Lemma hzremaindermoditerated ( m : hz ) (is : hzneq m ) ( n : hz ) 
: hzremaindermod m is ( hzremaindermod m is n ) ~> ( hzremaindermod m 
is n ) . Proof. intros. apply pathsinvO. apply ( hzqrtestr m is ( 
hzremaindermod m is n ) ( hzremaindermod m is n ) ). split, apply 
hzqrandremaindereq. apply hzqrandr emainderineq . Defined. 

Lemma hzqrandremainderq ( m : hz ) ( is ; hzneq Om) (n;hz) :0 
"> hzquotientmod m is ( hzremaindermod m is n ) , Proof, 
intros . apply ( hzqrtestq m is ( hzremaindermod m is n ) ( 
hzremaindermod m is n ) ). split, apply hzqrandremaindereq. apply 
hzqrandr emainderineq . Defined. 

(** * III. THE EUCLIDEAN ALGORITHM *) 

Definition iscommonhzdiv ( k n m : hz ) := dirprod ( hzdiv k n ) ( 
hzdiv km). 

Lemma isapropiscommonhzdiv ( k n m : hz ) : isaprop ( iscommonhzdiv k 
n m ). Proof. intros. unfold isaprop. apply isofhleveldirprod. apply 
hzdiv. apply hzdiv. Defined. 

Definition hzgcd ( n m : hz ) : UU := total2 ( fim k : hz => dirprod ( 
iscommonhzdiv k n m ) ( forall 1 : hz, iscommonhzdiv 1 n m -> hzleh 1 
k ) ). 

Lemma isaprophzgcdO ( k n m : hz ) : isaprop ( dirprod ( iscommonhzdiv 
k n m ) ( forall 1 : hz, iscommonhzdiv 1 n m -> hzleh Ik)). Proof, 
intros. apply isofhleveldirprod. apply isapropiscommonhzdiv. apply 
impred. intro t. apply impredfun. apply hzleh. Defined. 

Lemma isaprophzgcd ( n m : hz ) : isaprop ( hzgcd n m ). Proof, 
intros. intros k 1. assert ( isofhlevel 2 ( hzgcd n m ) ) as aux. 
apply isof hleveltotal2 . apply isasethz . intros x . apply hlevelntosn. 
apply isofhleveldirprod, apply isapropiscommonhzdiv . apply 
impred. intro t. apply impredfun. apply ( hzleh t x ). assert ( k ~> 
1 ) as f . destruct k as [ k pq ] . destruct pq as [ p q ] . destruct 1 
as [ 1 pq ] . destruct pq as [ p* q' ] . assert ( k ~> 1 ) as fO. apply 
isantisymmhzleh, apply q' , assumption, apply q, assumption. 

apply pathintotalf iber with ( pO := fO ). assert ( isaprop ( 
dirprod ( iscommonhzdiv 1 n m ) ( forall x : hz, iscommonhzdiv x n m 
-> hzleh X 1 ) ) ) as is. apply isofhleveldirprod. apply 
isapropiscommonhzdiv . apply impred. intro t . apply impredfun, apply 
( hzleh t 1 ). apply is, split with f. intro g. destruct k as [ k 
pq ] . destruct pq as [ p q ] , destruct 1 as [ 1 pq ] . destruct pq 
as [ p' q' ]. apply aux. Defined, 

(* Euclidean algorithm for calculating the CCD of two numbers (here 
assumed to be natural numbers ( m <= n )): 

gcd (n,m) :=1. ifm=0, then take n. 2. if m \neq 0, then 
divide n = q * m + r and take g := gcd ( m , r ). *) 

Lemma hzdivandmultl (acd:hz) (p: hzdiv da): hzdiv d ( c »< a 
). Proof. intros. intros P s. apply p. intro k. destruct k as [ k f 



], apply s. unfold hzdivO, split with ( c * k ). rewrite { hzmultcomm 
d ). rewrite ( hzmultassoc ). unfold hzdivO in f. rewrite ( 
hzmultcomm k ). rewrite f. apply idpath. Defined. 

Lemma hzdivandmultr (acd:hz) Cp: hzdiv da): hzdiv d ( a * c 
) . Proof . intros . rewrite hzmultconmi. apply 
hzdivandmultl . assumpt ion . Def ined . 

Lemma hzdivandminus ( a d : hz ) C p : hzdiv da): hzdiv d ( - a ) . 
Proof. intros. intros P s. apply p. intro k. destruct k as [ k f 
]. apply s. split with C - k ). unfold hzdivO. unfold hzdivO in 
f. rewrite C rngrmultminus hz ), apply raaponpaths. assumption. 
Defined, 

Definition natgcd ( m n : nat ) : ( natneq 0>inat n ) -> C natleh m n ) 

-> C hzgcd C nattohz n ) ( nattohz m ) ) . Proof . set ( E : = C fun m 

: nat => forall n : nat, ( natneq 0°/Snat n ) -> ( natleh m n ) -> ( 

hzgcd ( nattohz n ) ( nattohz m ) ) ) ) . assert ( forall x : nat, E x 

) as goal, apply stronginduction . (* BASE CASE: *) intros n xO 

xl. split with C nattohz n ). split, unfold iscommonhzdiv . 

split, unfold hzdiv, intros P s. apply s. unfold hzdivO. split with 

1. rewrite hzmultrl . apply idpath. unfold hzdiv. intros P s. apply 

s. unfold hzdivO. split with 0. rewrite hzmultxO. rewrite 

nattohzandO. apply idpath. intros 1 t. destruct t as [ tO tl 

] . destruct C hzgthorleh 1 ) as [ left I right ] . rewrite <- 

hzabsvalgthO, apply nattohzandleh. unfold hzdiv in tO, apply tO. intro 

t2. destruct t2 as [ k t2 ] . unfold hzdivO in t2. assert ( coprod ( 

natleh ( hzabsval 1 ) n ) ( n ~> 0/inat ) ) as C. apply ( natdivleh ( 

hzabsval 1 ) ( n ) ( hzabsval k ) ) . apply ( isinclisinj 

isinclnattohz ) . rewrite nattohzandmult . rewrite 2 ! 

hzabsvalgehO . assumption, assert ( hzgeh (l*k) Cl*0))asi. 

rewrite hzmultxO. rewrite t2. chajige with ( nattohz 0°/,nat ). apply 

nattohzandgeh . apply xl. apply ( hzgehandmultlinv _ _ 1 

). assumption, assumption, apply hzgthtogeh. assumption, destruct C 

as [CO I CI ] . assumption. assert empty, apply xO. apply 

pathsinvO. assumption, contradiction, assumption. apply ( 

istranshzleh _ _ ). assumption. change with ( nattohz 0'/,nat 

). apply nattohzandleh, assumption. C* INDUCTION CASE: *) intros m p 

q. intros n i j , 

assert ( hzlth ( nattohz m ) ) as p' , change with ( nattohz 
OVjiat ). apply nattohzandlth . apply natneqOtogthO. apply p. set C 
a := divalgorithmnonneg n m p' ). destruct a as [ qr a ] . destruct 
qr as [ quot rem ] . destruct a as [fa], destruct a as [ a b 
]. simpl in b. simpl in f. assert ( natlth ( hzabsval rem ) m ) 
as p' ' . rewrite <- ( hzabsval andnattohz m ). apply 
nattohzandlthinv . rewrite 2! hzabsvalgehO . assumption, apply 
hzgthtogeh . apply ( hzgthgehtrans _ rem ) . 

assumption, assumption, assumption. assert C natleh C hzabsval rem 
) n ) as i''. apply natlthtoleh. apply nattohzandlthinv. rewrite 
hzabsvalgehO. apply C hzlthlehtrans „ C nattohz m ) _ 
) . assumption, apply nattohzandleh. assumption, assumption, 
assert C natneq OXnat m ) as p'''. intro ff. apply p. apply 
pathsinvO. assumption. destruct ( q C hzabsval rem ) p'' m p''' ( 
natlthtoleh __p'' ) ) as [rrc]. destruct c as [ cO cl ] . 
split with rr. split, split, apply ( hzdivlinearcombright ( 
nattohz n ) ( nattohz m * quot ) ( rem ) rr f ) . apply 
hzdivandmultr. exact ( pri cO ). rewrite hzabsvalgehO in cO. exact 
( pr2 cO ). assumption, exact ( prl cO ). 

intros 1 o. apply cl. split, exact ( pr2 o ). rewrite hzabsvalgehO. 
apply C hzdivlinearcorablef t C nattohz n ) ( nattohz m * quot ) ( 
rem ) 1 f ). exact ( prl o ). apply hzdivandmultr. exact ( pr2 o 
) . assumption. assumption. Defined. 



Lemma hzgcdandminusl ( m n : hz ) : hzgcd m n ~> hzgcd ( - m ) n. 



Proof. intros. assert ( hProppair ( hzgcd m n ) ( isaprophzgcd _ _ ) 
~> C hProppair ( hzgcd ( - m ) n ) ( isaprophzgcd _ _ ) ) ) as 
X. apply uahp. intro i. destruct i as [ a i ]. destruct i as [ iO il 
]. destruct iO as [ jO jl ] . split with a. split, split, apply 
jO. intro k. destruct k as [ k f ]. unfold hzdivO in f. intros P s. 
apply s. split with ( - k ). unfold hzdivO. rewrite C rngrmultminus hz 
). apply maponpaths. assumption, assumption, intros 1 f. apply il. 
split, apply C prl f ). intro k. destruct k as [kg], unfold hzdivO 
in g. intros P s. apply s. split with ( - k ). unfold hzdivO. 
rewrite ( rngrmultminus hz ) . rewrite <- ( rngminusminus hz m) . apply 
maponpaths. assumption, exact C pr2 f ). intro i. destruct i as [ a i 
]. destruct i as [ iO il ] . destruct iO as [ jO jl ] . split with 
a. split, split, apply jO, intro k. destruct k as t k f ]. unfold 
hzdivO in f, intros P s, apply s, split with ( - k ). unfold hzdivO. 
rewrite ( rngrmultminus hz ) . rewrite <- ( rngminusminus hz m ) . 
apply maponpaths. assumption, assumption. intros 1 f . apply 
il. split, apply C prl f ). intro k. destruct k as [kg], unfold 
hzdivO in g. intros P s. apply s. split with ( - k ). unfold hzdivO. 
rewrite (rngrmultminus hz ). apply maponpaths. assumption, exact C pr2 
f ). apply C pathintotalprl x ). Defined. 

Lenrnia hzgcdsymm ( m n : hz ) : hzgcd m n ~> hzgcd n m. Proof, 
intros. assert ( hProppair ( hzgcd m n ) ( isaprophzgcd __)">( 
hProppair ( hzgcd n m ) ( isaprophzgcd _ _ ) ) ) as x. apply 
uahp. intro i. destruct i as [ a i ]. destruct i as [ iO il 
]. destruct iO as [ jO jl ] . split with 

a . split . split . assumption . assumption . intros 1 o . apply 

il. split, exact ( pr2 o ). exact ( prl o ). intro i. destruct i as [ 

a i ]. destruct i as [ iO il ] . destruct iO as [ jO jl ]. split with 

a. split, split, assumption, assumption, intros 1 o. apply 

il. split, exact C pr2 o ). exact C prl o ). apply C pathintotalprl x 

) . Defined. 

Lemma hzgcdandminusr C m n : hz ) : hzgcd m n "> hzgcd m ( - n ) . 
Proof. intros. rewrite 2! C hzgcdsymm m ). rewrite 
hzgcdandminusl . apply idpath . Def ined . 

Definition euclidean C n m : hz ) C i : hzneq On) ( p : natleh ( 
hzabsval m ) ( hzabsval n ) ) : hzgcd n m. Proof. intros. assert ( 
natneq O/inat ( hzabsval n ) ) as j . intro x. apply i. assert C 
hzabsval n ~> O'/jiat ) as f . apply pathsinvO. assumption, rewrite ( 
hzabsvaleqO f ). apply idpath. set C a := natgcd C hzabsval m ) C 
hzabsval n ) j p ) . destruct C hzlthorgeh n ) as [ left_n I ri^t_n 
] . destruct C hzlthorgeh m ) as [ left_m I right_m ] . rewrite 2! C 
hzabsvalgthO ) in a . assumption . assumption . assumption . rewrite 
hzabsvalgthO in a. rewrite hzabsvallehO in a. rewrite 
hzgcdandminusr . assumption, assumption . assumption . destruct ( 
hzlthorgeh m ) as [ left_m t right_m ] . rewrite C hzabsvalgthO 
left_ni ) in a. rewrite hzabsvallehO in a. rewrite 

hzgcdandminusl . assumption, assumption, rewrite 2 ! hzabsvallehO in 
a. rewrite hzgcdajidminusl . rewrite hzgcdandminusr , 
assumption, assumption, assumption. Defined, 

Theorem euclideanalgorithm ( n m : hz ) ( i : hzneq On): iscontr ( 
hzgcd n m ) . Proof . intros . destruct C natgthorleh ( hzabsval m ) ( 
hzabsval n ) ) as [ left I right ]. assert C hzneq m ) as i' . intro 
f. apply C negnatlthnO C hzabsval n ) ). rewrite <- f in 
left, rewrite hzabsvalO in left, assumption. set ( a := C euclidean m 
n i' ( natlthtoleh _ _ left ) ) ). rewrite hzgcdsymm in a. split with 
a. intro. apply isaprophzgcd. split with ( euclidean n m i right 
). intro. apply isaprophzgcd. Defined. 

Definition gcd ( n m : hz ) C i : hzneq On) : hz := prl ( prl ( 
euclideanalgorithm n m i ) ) . 



Definition gcdiscommondiv ( n m : hz ) ( i : hzneq On) := prl ( pr2 



( prl C euclideanalgorithm n m i ) ) ) . 

Definition gcdisgreatest ( n m : hz ) ( i : hzneq On) := pr2 ( pr2 ( 
prl C euclideanalgorithm n m i ) ) ) . 

Lemma hzdivandO ( n : hz ) : hzdiv n 0. Proof. intros. intros P 
s. apply s. split with 0. unfold hzdivO. apply hzmultxO, Defined. 

Lemma nozerodiv ( n : hz ) ( i ; hzneq On): neg ( hzdiv On). 
Proof. intros. intro p. apply i. apply C p C hProppair ( ~> n ) ( 
isasethz On) ) ). intro t. destruct t as [ k f ] . unfold hzdivO in 
f. rewrite C hzmultOx ) in f . assumption. Defined. 

{** * IV. Bezout's lemma and the commutative ring Z/pZ *) 

Lemma commonhzdivsignswap (knm:hz)(p: iscommonhzdiv k n m ) : 
iscommonhzdiv ( - k ) n m . Proof. intros. destruct p as [ pO pi ] . 
split, apply pO. intro t. intros P s. apply s. destruct t as [If 
]. unfold hzdivO in f. split with ( - 1 ). unfold hzdivO. change ( k 
* 1 ) with { k * 1 )°/,rng in f, rewrite <- rngmultminusminus in 
f. assumption, apply pi- intro t, destruct t as [If], unfold 
hzdivO in f . intros P s , apply s , split with { - 1 ) . unfold 
hzdivO. change ( k * 1 ) with ( k * 1 )%rng in f , rewrite <- 
rngmultminusminus in f . assumption. Defined. 

Lemma gcdneqO C n m : hz ) ( i : hzneq On): hzneq ( gcd n m i ) . 
Proof, intros, intro f, apply ( nozerodiv n ). assumption. rewrite 
f. exact C prl ( gcdiscommondiv n m i ) ). Defined. 

Lemma gcdpositive ( n m : hz ) ( i : hzneq On): hzlth C gcd n m i 
), Proof, intros, destruct C hzneqchoice ( gcd n m i ) ( gcdneqO n 
m i ) ) as [ left I right ]. assert empty, assert C hzleh { - { gcd n 
m i ) ) C gcd n m i ) ) as iO. apply C gcdisgreatest n m i ). apply 
commonhzdivsignswap. exact C gcdiscommondiv n m i ). apply ( 
isirref Ihzlth ) . apply ( istranshzlth _ C - C gcd n m i ) ) _ ) . 
apply hzlthOandminus . assumption, apply ( hzlehlthtrans _ ( gcd n m i 
) _ ) . assumption, assumption, contradiction, assumption. Defined. 

Lemma gcdanddiv ( n m : hz ) ( i : hzneq On) C p : hzdiv n m ) : 
coprod C gcd n m i "> n ) ( gcd n m i "> - n ) . Proof, 
intros. destruct ( hzneqchoice n i ) as [ left I right ]. apply 
ii2. apply Isantlsymrnhzleh. apply C hzdivhzabsval ( gcd n m i ) n ( 
prl ( gcdiscommondiv n m i ) ) ). intro c' . destruct c' as [ cO I cl 
], rewrite <- C hzabsvalgehO ). rewrite <- C hzabsvallthO ). apply 
nattohzandleh, assumption, assumption, apply hzgthtogeh. apply C 
gcdpositive n m i) . assert empty, assert ( n ~> ) as f, rewrite 
hzabsvaleqO. apply idpath. assumption, apply i. apply 
pathsinvO. assumption, contradiction. apply C pr2 ( pr2 ( prl C 
euclideanalgorithm n m i ) ) ) ) . apply 

commonhzdivsignswap , split . apply hzdivisref 1 . assumption. apply 
iil, apply isantisymmhzleh, apply ( hzdivhzabsval ( gcd n m i ) n ( 
prl C gcdiscommondiv n m i ) ) ). intro c', destruct c' as [ cO I cl 
], rewrite <- hzabsvalgthO . assert C n "> nattohz ( hzabsval n ) ) as 
f . apply pathsinvO. apply hzabsvalgthO. assumption, assert ( hzleh ( 
nattohz ( hzabsval ( gcd n m i ) ) ) ( nattohz ( hzabsval n ) ) ) as 
j. apply nattohzandleh. assumption, exact ( transportf ( fun x : _ => 
hzleh C nattohz ( hzabsval ( gcd nmi)))x) ( pathsinvO f ) j ) . 
apply gcdpositive. assert empty, apply i. apply pathsinvO. rewrite 
hzabsvaleqO . apply idpath . assumption . contradiction . apply ( 
gcdisgreatest n m i ). split, apply hzdivisrefl. assumption. Defined. 

Lemma gcdandO C n : hz ) { i : hzneq On): coprod ( gcd n i "> n ) 
C gcd nOi~>-n). Proof, intros. apply gcdanddiv. apply 
hzdivandO . Defined. 

Lemma natbezoutstrong ( m n : nat ) ( i : hzneq ( nattohz n ) ) : 



total2 C fun ab : dirprod hz hz => C gcd ( nattohz n ) ( nattohz m ) i 
~> C ( prl ab ) * ( nattohz n ) + ( pr2 ab ) * ( nattohz m ) ) ) ) . 
Proof. set C E := C fun m : nat => forall n : nat, forall i : hzneq 
C nattohz n ) , total2 ( fun ab : dirprod hz hz => gcd ( nattohz n ) C 
nattohz m ) i ~> C ( prl ab ) * C nattohz n ) + ( pr2 ab ) * ( nattohz 
m ) ) ) ) ) . assert C forall x : nat , E x ) as goal . apply 
stronginduction. C* Base Case: *) unfold E. intros. split with C 
dirprodpair 10). simpl. rewrite nattohzandO. destruct C gcdandO ( 
nattohz n ) i ) as [ left I right ]. rewrite hzmultll, rewrite 
hzplusrO . assumption . assert empty . apply ( isirref Ihzlth ( gcd ( 
nattohz n ) i ) ) . apply ( Istranshzlth _ _ ) . rewrite 
right . apply hzgthOandminus . change with C nattohz Ojjnat ) . apply 
nattohzandgth . apply natneqOtogthO . intro f . apply i . rewrite 
f . apply idpath . apply gcdpositive . contradiction, (* Induction 
Case: *) intros m x y. intros n i. assert ( hzneq ( nattohz m ) ) 
as p . intro f . apply x . apply pathsinvO . rewrite <- 
hzabsvalandnattohz. change OJinat with C hzabsval ( nattohz OUnat ) 
). apply maponpaths . assumption. set C r := hzremaindermod ( nattohz 
m ) p C nattohz n ) ). set C q := hzquotientmod C nattohz m ) p ( 
nattohz n ) ). assert ( natlth (hzabsval r ) m ) as p' , rewrite <- ( 
hzabsvalandnattohz m ). apply hzabsvalandlth. exact ( 
hzlehOremaindermod ( nattohz m ) p ( nattohz n ) ), unfold r. unfold 
hzremaindermod. rewrite <- ( hzabsvalgehO C prl ( pr2 ( pr2 ( 
divalgorithmexists C nattohz n ) ( nattohz m)p))))). apply 
nattohzandlth. assert ( natlth ( hzabsval Cpr2 Cprl 
(divalgorithmexists (nattohz n) (nattohz m) p))) ) C ( hzabsval ( 
nattohz m ) ) ) ) as ii. apply hzabsvalandlth. exact ( 
hzlehOremaindermod ( nattohz m ) p ( nattohz n ) ) . assert ( nattohz 
C hzabsval ( nattohz m ) ) "> C nattohz m ) ) as f . apply 
maponpaths. apply hzabsvalandnattohz. exact ( transportf ( fun x : _ 
=> hzlth Cpr2 Cprl (divalgorithmexists (nattohz n) (nattohz m) p) ) ) x 
) f ( pr2 ( pr2 ( pr2 ( divalgorithmexists ( nattohz n ) ( nattohz m ) 
p ) ) ) ) ) . exact ( transportf ( fiui x ; _ => natlth ( hzabsval (pr2 
Cprl (divalgorithmexists (nattohz n) (nattohz m) p))) ) x ) ( 
hzabsvalandnattohz m ) ii ) . set C c := y ( hzabsval r ) p' m p ) . 
destruct c as [ ab f ] . destruct ab as [ a b ]. simpl in f , (* split 
with C dirprodpair ( ( nattohz n ) - q * ( nattohz ra)) (a-b*q) 
).*) split with ( dirprodpair b (a-b*q) ). assert ( gcd ( 
nattohz m ) ( nattohz ( hzabsval r ) ) p ~> ( gcd ( nattohz n ) ( 
nattohz m ) i ) ) as g. apply isantisymmhzleh, apply ( gcdisgreatest 
( nattohz n ) ( nattohz m ) i ). split, apply ( hzdivlinearcombri^t 
C nattohz n ) C ( nattohz m ) * ( hzquotientmod C nattohz m ) p ( 
nattohz n ) ) ) r ). exact ( hzdivequationmod ( nattohz m ) p ( 
nattohz n ) ). apply hzdivandmultr . apply gcdiscommondiv. unfold 
r. rewrite ( hzabsvalgehO ( hzlehOremaindermod ( nattohz m ) p ( 
nattohz n ) ) ) . apply ( pr2 ( gcdiscommondiv ( nattohz m ) ( 
hzremaindermod ( nattohz m ) p ( nattohz n ) ) p ) ) • apply 
gcdiscommondiv. apply gcdisgreatest. split, apply ( pr2 C 
gcdiscommondiv _ _ _ ) ) . apply ( hzdivlinearcomblef t ( nattohz n ) ( 
( nattohz m ) * ( hzquotientmod ( nattohz m ) p ( nattohz n ) ) ) ( 
nattohz ( hzabsval r ) ) ). unfold r. rewrite ( hzabsvalgehO ( 
hzlehOremaindermod ( nattohz m ) p ( nattohz n ) ) ) . exact C 
hzdivequationmod ( nattohz m ) p ( nattohz n ) ) . apply 
gcdiscommondiv. apply ( hzdivandmultr ). apply ( pr2 ( gcdiscommondiv 
_ _ _ ) ). rewrite <~ g. rewrite f. simpl. assert ( nattohz ( 
hzabsval r ) ~> ( ( nattohz n ) - ( q * nattohz ra ) ) ) as h. rewrite 
C hzdivequationmod ( nattohz m ) p ( nattohz n ) ) . change ( 
hzquotientmod ( nattohz m ) p ( nattohz n ) ) with q. change ( 
hzremaindermod ( nattohz m ) p ( nattohz n ) ) with r. rewrite 
hzpluscomm. change (r + nattohz m * q - q * nattohz m) with ( ( r + 
nattohz m*q)+C-Cq* nattohz m ) ) ) . rewrite 
hzmultcomm. rewrite hzplusassoc. change (q * nattohz m + - Cq * 
nattohz m)) with ( (q * nattohz m - (q * nattohz m) ) ) . rewrite 
hzrminus. rewrite hzplusrO. apply hzabsvalgehO. apply ( 
hzlehOremaindermod ( nattohz m ) p ( nattohz n ) ). rewrite h. change 
C (nattohz n - q * nattohz m) ) with ( (nattohz n + ( - ( q * nattohz 



m) ) ) ) at 1. rewrite ( rngldistr hz ). rewrite <- C hzplusassoc ). 
rewrite ( hzpluscomm (a * nattohz m ) ) . rewrite 
mgrmultminus . rewrite <- hzmultassoc . rewrite <- 
mglmultmiiius . rewrite hzplusassoc. rewrite <- ( rngrdistr hz ). 
change Cb * nattohz n + (a - b * q) * nattohz m) with C(b * nattohz 
n)*/.mg + ((a + - (b * q)°/Jiz) * nattohz m)°/,mg) . apply idpath. apply 
goal. Defined. 

Lemma divandhzabsval ( n : hz ) : hzdiv n { nattohz ( hzabsval n ) ) . 
Proof. intros. destruct ( hzlthorgeh n ) as [ left I right ]. 
intros P s. apply s, split with 1. unfold hzdivO. rewrite hzmultrl. 
rewrite hzabsvalgthO . apply idpath. assumption. intros P s. apply 
s, split with C - l%hz ). unfold hzdivO. rewrite C mgrmultminus hz 
), rewrite hzmultrl. rewrite hzabsvallehO . apply idpath. assumption. 
Defined. 

Lemma bezoutstrong ( m n : hz ) ( i : hzneq On): total2 C fun ab : 
dirprod hz hz => ( gcd n m i ~> ( ( prl ab ) * n + ( pr2 ab ) * m ) ) 
), Proof, intros, assert ( hzneq C nattohz ( hzabsval n ) ) ) as 
i'. intro f. apply i. destruct ( hzneqchoice n i ) as [ left I 
right ] . rewrite hzabsvallthO in f , rewrite <- ( rngminusminus hz 
) . change with ( - - ) . apply 

maponpaths . assumption, assumption, rewrite hzabsvalgthO in 

f. assumption, assumption, set C c := (nat bezoutstrong (hzabsval m) 

(hzabsval n) i')). destruct c as [ ab f ] . destruct ab as [ a b 

], simpl in f. assert ( gcd n m i ~> gcd ( nattohz ( hzabsval n ) ) ( 

nattohz ( hzabsval m ) ) i' ) as g. destruct ( hzneqchoice n i ) as 

[ left_n I right_n ] . apply isantisymmhzleh. apply 
gcdisgreatest. split, rewrite hzabsvallthO. apply 
hzdivandminus . apply gcdiscommondiv. assumption. destruct ( 
hzlthorgeh m ) as [ left_m 1 right_m ] . rewrite hzabsvalgthO. 
apply ( pr2 C gcdiscommondiv _ _ _ ) ). assumption, rewrite 
hzabsvallehO. apply hzdivandminus. apply ( pr2 ( gcdiscommondiv _ _ _ 
) ). assumption, apply gcdisgreatest. split, apply ( hzdivistrans _ 

( nattohz ( hzabsval n ) ) _ ). apply gcdiscommondiv. rewrite 
hzabsvallthO, rewrite <- ( rngminusminus hz n ) . apply 
hzdivandminus, rewrite ( rngminusminus hz n ) . apply hzdivisrefl. 
assumption, apply C hzdivistrans _ ( nattohz ( hzabsval m ) ) _ ). 
apply ( pr2 ( gcdiscommondiv _ _ _ ) ) . destruct ( hzlthorgeh m ) 
as [ left_m I right _m ], rewrite hzabsvalgthO, apply 
hzdivisrefl . assumption. rewrite hzabsvallehO , rewrite <- ( 
rngminusminus hz m ) . apply hzdivandminus . rewrite ( rngminusminus hz 
m ). apply hzdivisrefl. assumption. apply isantisymmhzleh. apply 
gcdisgreatest , split . rewrite hzabsvalgthO , apply 
gcdiscommondiv, assumption. apply ( hzdivistrans _ ( nattohz ( 
hzabsval m ) ) _ ) . destruct ( hzlthorgeh m ) as [ lef t_m I right_m 
] . rewrite hzabsvalgthO . apply ( pr2 ( gcdiscommondiv _ _ _ ) ) . 
assumption, rewrite hzabsvallehO. apply hzdivandminus. apply ( pr2 ( 
gcdiscommondiv _ _ _ ) ). assumption, apply hzdivisrefl. apply 
gcdisgreatest, split. apply ( hzdivistrans _ ( nattohz ( hzabsval n ) 
) _ )- apply gcdiscommondiv. rewrite hzabsvalgthO. apply 
hzdivisrefl, assumption. apply ( hzdivistrans _ ( nattohz ( hzabsval 
m ) ) _ ) . apply ( pr2 ( gcdiscommondiv _ _ _ ) ) . destruct ( 
hzlthorgeh m ) as [ left_m I right_m ]. rewrite hzabsvalgthO. apply 
hzdivisrefl . assumption, rewrite hzabsvallehO. rewrite <- ( 
rngminusminus hz m ) . apply hzdivandminus . rewrite ( rngminusminus hz 
m ). apply hzdivisrefl. assumption, destruct C hzneqchoice n i ) as 

[ lef t_n I right_n ] . destruct C hzlthorgeh m ) as [ left_m I 
right_m ] . 

split with ( dirprodpair ( - a ) b ). simpl. assert (-a*n+b* 
m ~> ( a * ( nattohz ( hzabsval n ) ) + b * ( nattohz ( hzabsval m ) 
) ) ) as 1. rewrite hzabsvallthO. rewrite hzabsvalgthO. rewrite ( 
rnglmultminus hz ) . rewrite <- ( mgrmultminus hz ) . apply 
idpath. assumption, assumption, rewrite 1 . rewrite g. exact 
f. split with C dirprodpair (-a) (-b) ). simpl. rewrite 2! ( 



rnglmultminus hz ) , rewrite <- 2 ! ( mgrmultminus hz ) , rewrite <- 
( hzabsvallthO ). rewrite <- ( hzabsvallehO ). rewrite g. exact 

f . assumption, assumption. destruct ( hzlthorgeh m ) as [ left_m 
I right _m ]. split with ( dirprodpair a b ). simpl. rewrite 

g. rewrite f . rewrite 2 ! hzabsvalgthO . apply 

idpath. assumption, assumption. split with ( dirprodpair a ( - b ) 
). rewrite g. rewrite f. simpl. rewrite hzabsvalgthO. rewrite 
hzabsvallehO. rewrite ( mgrmultminus hz ). rewrite <- ( 
rnglmultminus hz ). apply idpath. assumption, assumption. Defined. 



(** * V. Z/nZ *) 



Lemma hzmodisaprop ( p ; hz ) ( x : hzneq Op) Cnm:hz) : isaprop 
( hzremaindermod p x n ~> ( hzremaindermod p x m ) ). Proof, 
intros . apply isasethz. Defined. 

Definition hzmod ( p : hz ) ( x : hzneq Op) : hz -> hz -> hProp. 
Proof, intros p x n m. exact C hProppair ( hzremaindermod p x n "> ( 
hzremaindermod p x m ) ) ( hzmodisaprop p x n m ) ). Defined. 

Lemma hzmodisref 1 ( p : hz ) C x : hzneq Op): isref 1 ( hzmod p x ) . 
Proof. intros. unfold isrefl, intro n. unfold hzmod. assert ( 
hzremaindermod p x n ~> ( hzremaindermod p x n ) ) as a. auto, apply 
a. Defined. 



Lemma hzmodissymm ( p : hz ) ( x : hzneq Op): issymm ( hzmod p x ) . 
Proof. intros. unfold issymm, intros n m, unfold hzmod, intro v. 
assert ( hzremaindermod p x m ~> hzremaindermod p x n ) as a. exact ( 
pathsinvO ( v ) ). apply a. Defined. 

Lemma hzmodistrans ( p : hz ) ( x : hzneq Op): istrans ( hzmod p x 
). Proof. intros. unfold istrans. intros n m k. intros u v, unfold 
hzmod. unfold hzmod in u. unfold hzmod in v. assert ( hzremaindermod 
p X n ~> hzremaindermod p x k ) as a. exact ( pathscompO u v ). apply 
a. Defined. 



Lemma hzmodiseqrel ( p : hz ) ( x : hzneq Op): iseqrel ( hzmod p x 
). Proof. intros. apply iseqrelconstr. exact ( hzmodistrans p x 
). exact ( hzmodisrefl p x ). exact C hzmodissymm p x ), Defined. 

Lemma hzmodcompatmultl ( p : hz ) ( x : hzneq Op): forall a b c : 
hz , hzmod p x a b -> hzmod pxCc*a) (c*b). Proof . intros p 
X a b c V. unfold hzmod. change (hzremaindermod p x (c * a) ~> 
hzremaindermod p x (c * b)). rewrite hzremaindermodandtimes . rewrite 
v. rewrite <- hzremaindermodandtimes. apply idpath. Defined. 

Lemma hzmodcompatmultr ( p : hz ) ( x : hzneq Op): forall a b c : 
hz , hzmod p x a b -> hzmod pxCa*c) (b*c). Proof . intros p 
X a b c v. rewrite hzmultcoiom. rewrite ( hzmultcomm b ). apply 
hzmodcompatmultl . assumption. Defined. 

Lemma hzmodcompatplusl ( p : hz ) C x : hzneq Op): forall a b c : 
hz, hzmod p x a b -> hzmod px(c+a) (c+b). Proof. intros p 
X a b c V. unfold hzmod. change ( hzremaindermod px(c+a)~> 
hzremaindermod px(c-*-b)). rewrite 
hzremaindermodandplus . rewrite v. rewrite <- 
hzremaindermodandplus , apply idpath. Defined. 

Lemma hzmodcompatplusr ( p : hz ) ( x : hzneq Op): forall a b c : 
hz , hzmod p x a b -> hzmod pxCa+c) (b+c). Proof . intros p 
X a b c V. rewrite hzplusconmi. rewrite ( hzpluscomm b ). apply 
hzmodcompatplusl , assumption. Defined . 



Lemma hzmodisrngeqrel ( p : hz ) ( x : hzneq Op): rngeqrel ( X := 
hz ). Proof, intros. split with ( tpair ( hzmod p x ) ( hzmodiseqrel 
p X ) ). split, split, apply hzmodcompatplusl. apply 



hzmodcompatplusr . split . apply hzmodcompatmultl . apply 
hzmodcompatmultr . Defined. 

Definition hzmodp ( p : hz ) C x : hzneq p ) := commrngquot C 
hzmodismgeqrel p x ) . 

Lemma isdeceqhzmodp ( p : hz ) C x : hzneq Op): isdeceq ( hzmodp p 
X ). Proof. intros, apply C isdeceqsetquot C hzmodismgeqrel p x ) 
), intros a b. unfold isdecprop. destruct ( isdeceqhz ( 
hzremaindermod p x a ) ( hzremaindermod pxb))as[l|r], 
unfold hzmodismgeqrel. simpl. split with ( iil 1 ). intros t. 
destmct t as [ f I g ]. apply maponpaths. apply isasethz. assert 
empty, apply g. assumption, contradiction. split with C ii2 r 
), intros t. destruct t as [ f I g ]. assert empty, apply r. 
assumption, contradiction, apply maponpaths. apply isapropneg. 
Defined. 

Definition acoinmrng_hzmod ( p : hz ) C x : hzneq Op): acommrng. 
Proof. intros, split with ( hzmodp p x ). split with ( tpair _ ( 
deceqtoneqapart ( isdeceqhzmodp p x ) ) ). split, split, intros a b c 
q. simpl. simpl in q. intro f. apply q. rewrite f. apply idpath. 
intros a b c q, simpl in q. simpl. intro f. apply q, rewrite f. apply 
idpath, split, intros a b c q. simpl in q. simpl, intros f. apply 
q, rewrite f . apply idpath. intros a b c q. simpl. simpl in q. intro 
f, apply q. rewrite f. apply idpath. Defined. 

Lemma hzremaindermodanddiv ( p : hz ) C x : hzneq Op) Ca:hz) (y 
: hzdiv pa): hzremaindermod p x a ~> 0. Proof, intros, assert ( 
isaprop ( hzremaindermod pxa~>0) ) asv. apply isasethz. apply ( 
y C hProppair _ v ) ). intro t. destruct t as [ k f ], unfold hzdivO 
in f. assert (a~> Cp*k+0) ) asf. rewrite f. rewrite 
hzplusrO, apply idpath. set ( e tpair { P (fun qr : dirprod hz 
hz => dirprod (a ~> (p * prl qr + pr2 qr)) (dirprod (hzleh Cpr2 qr)) 
(hzlth Cpr2 qr) (nattohz (hzabsval p))))) ) ( dirprodpair k ) ( 
dirprodpair f * C dirprodpair ( isreflhzleh ) ( hzabsvalneqO p x ) ) 
) ). assert C e ~> ( prl C divalgorithm apx)))ass, apply C pr2 
C divalgorithm a p x ) ). set ( w := pathintotalprl ( pathsinvO s ) 
), unfold e in w. unfold hzremaindermod. apply C maponpaths ( fun z : 
dirprod hz hz => pr2 z ) w ). Defined. 

Lemma gcdandprime ( p : hz ) ( x : hzneq Op) C y : isaprime p ) ( a 
: hz ) C q : neg C hzmod p x a ) ) : gcd p a x ~> 1. Proof, 
intros. assert C isaprop ( gcd p a x ~> 1) ) as is. apply ( isasethz 
) , apply C pr2 y C gcd p a x ) C prl ( gcdiscommondiv pax)) ( 
hProppair _ is ) ). intro t. destruct t as [ tO I tl ] . apply 
tO. assert empty. apply q. simpl. assert ( hzremaindermod p x a ~> 
) as f . assert C hzdiv pa) as u. rewrite <- tl. apply ( pr2 ( 
gcdiscommondiv _ _ _ ) ). rewrite hzremaindermodanddiv. apply 
idpath. assumption, rewrite f. rewrite hzqrandOr. apply 
idpath . contradiction . Defined. 

Lemma hzremaindermodandmultl { p : hz ) { x : hzneq Op) (ab:hz) 
: hzremaindermod pxCp*a + b) ~> hzremaindermod p x b. Proof, 
intros. assert Cp*a+b~> Cp* Ca+ hzquotientmod p x b ) + 
hzremaindermod p x b ) ) as f . rewrite hzldistr . rewrite 
hzplusassoc. rewrite <- C hzdivequationmod p x b ). apply 
idpath , rewrite hzremaindermodandplus . rewrite 
hzremaindermodandtimes . rewrite hzqrandself r . rewrite 
hzmultOx. rewrite hzqrandOr. rewrite hzpluslO. rewrite 
hzremaindermodit erated . apply idpath . Defined . 



7.7 The file padics.v 



Lemma hzmodprimeinv ( p : hz ) ( x : hzneq Op) C y : isaprime p ) C 
a : hz ) ( q : neg ( hzmod p x a ) ) : total2 ( fun v : hz => 
dirprod ( hzmod px{a*v) 1) { hzmod px Cv*a) 1) ). Proof . 
intros. split with ( pr2 ( prl ( bezoutstrong a p x ) ) ). assert ( 1 
~> (prl (prl (bezoutstrong a p x)) * p + pr2 (prl (bezoutstrong a p 
x)) * a) ) as f ' . assert ( 1 ~> gcd p a x ) as f'. apply 
pathsinvO. apply ( gcdandprime ) . assumption, assumption, rewrite 
f'. apply ( bezoutstrong a p x ), split. rewrite f ' . simpl, rewrite 
C hzmultcomm ( prl ( prl ( bezoutstrong apx) ) ) _), rewrite ( 
hzremaindermodandmultl ) , rewrite hzmultcomm. apply idpath. rewrite 
f ' . simpl . rewrite hzremaindermodandplus . rewrite C 
hzremaindermodandtimes p x _ p ). rewrite hzqrandself r . rewrite 
hzmultxO. rewrite hzqrandOr. rewrite hzpluslO. rewrite 
hzremaindermoditerated . apply idpath . Defined . 

Lemma quotientmgsumdecom ( X : comnLTOg ) ( R : rngeqrel (X := X ) ) 
C a b : X ) : Sop2 ( commrngquot R ) ( setquotpr R a ) ( setquotpr R b 
) ~> ( setquotpr R ( a * b )'/,rng ). Proof. intros, auto. Defined. 

Definition alizmod ( p : hz ) ( y : isaprime p ) : afld. Proof, 
intros. split with ( acommrng_hzmod p ( isaprimetoneqO y ) 
). split, simpl, intro f, apply ( isirref Ihzlth ), assert ( hzlth 
1 ) as i, apply hzlthnsn. change ( l°/,rng ) with ( setquotpr ( 
hzmodismgeqrel p ( isaprimetoneqO y ) ) 1/ihz ) in f . change ( OXrng ) 
with ( setquotpr ( hzmodismgeqrel p ( isaprimetoneqO y ) ) O'/hz 
) . assert ( (hzmodismgeqrel p ( isaprimetoneqO y ) ) l°/,hz 07,hz ) as 
o. apply ( setquotprpathsandR ( hzmodismgeqrel p ( isaprimetoneqO y ) 
) l%hz Oyjiz ). assumption, unfold hzmodismgeqrel in o. simpl in o, 
assert ( hzremaindermod p ( isaprimetoneqO y ) ~> ) as o' . rewrite 
hzqrandOr. apply idpath. rewrite o' in o. assert ( hzremaindermod p ( 
isaprimetoneqO y ) 1 ~> 1 ) as o ' ' . assert ( hzlth 1 p ) as v. apply 
y. rewrite hzqrandlr, apply idpath, rewrite o'' in o. assert ( hzlth 
1 ) as o'''. apply hzlthnsn. rewrite o in o'*'. assumption. assert 
C f orall xO : acommrng_hzmod p ( isaprimetoneqO y ) , isaprop ( ( xO # 
0)/irng -> multinvpair ( acommmg_hzmod p ( isaprimetoneqO y ) ) xO ) ) 
as int, intro a. apply impred, intro q, apply isapropmultinvpair . 
apply ( setquotunivprop _ ( fun xO => hProppair _ ( int xO ) ) ) . 
intro a, simpl. intro q. assert ( neg ( hzmod p ( isaprimetoneqO y ) 
a ) ) as q' . intro g. unfold hzmod in g. simpl in g. apply q. 
change ( 0°/,mg ) with ( setquotpr ( hzmodismgeqrel p ( isaprimetoneqO 
y ) ) 0/ihz ) . apply ( iscomp setquotpr ( hzmodismgeqrel p ( 
isaprimetoneqO y ) ) ). apply g. split with ( setquotpr ( 
hzmodismgeqrel p ( isaprimetoneqO y ) ) ( prl ( hzmodprimeinv p ( 
isaprimetoneqO y)yaq' ) ) ). split, simpl, rewrite ( 
quotientmgsumdecom hz ( hzmodismgeqrel p ( isaprimetoneqO y ) ) ) . 
change l^jnultmonoid with ( setquotpr ( hzmodismgeqrel p ( 
isaprimetoneqO y ) ) I'/hz ) . apply C iscompsetquotpr ( 
hzmodismgeqrel p ( isaprimetoneqO y ) ) ) . simpl. change Cpr2 (prl 
(bezoutstrong a p ( isaprimetoneqO y ))) * a)°/,rng with (pr2 (prl 
(bezoutstrong a p ( isaprimetoneqO y ))) * a)y,hz. exact ( ( pr2 ( pr2 
( hzmodprimeinv p ( isaprimetoneqO y ) y a q' ) ) )). simpl. rewrite 
( quotientmgsumdecom hz ( hzmodismgeqrel p ( isaprimetoneqO y ) ) ) . 
change l°/jnultmonoid with ( setquotpr ( hzmodismgeqrel p ( 
isaprimetoneqO y ) ) l°/.hz ) . apply ( iscompsetquotpr ( 
hzmodismgeqrel p ( isaprimetoneqO y ) ) ) , change (a * pr2 (prl 
(bezoutstrong a p ( isaprimetoneqO y ))))%rng with (a * pr2 (prl 
(bezoutstrong a p ( isaprimetoneqO y ))))%hz. exact ( ( prl ( pr2 ( 
hzmodprimeinv p ( isaprimetoneqO y) yaq' ) ) )). Defined. 

Close Scope hz_scope. 
(** END OF FILE *) 



(** *p adic numbers *) 



(** By Alvaro Pelayo, Vladimir Voevodsky and Michael A. Warren *) 

(** 2012 *) 
C** Settings *) 

Add Rec LoadPath "../Generalities". Add Rec LoadPath " . ./hlevell" . 

Add Rec LoadPath " . . /hlevel2" . Add Rec LoadPath 

" . ./Proof_of_Extensionality" . Add Rec LoadPath "../Algebra". 

Unset Automatic Introduction. (** This line has to be removed for the 
file to compile with Coq8.2 *) 

(** Imports *) 

Require Export lemmas . 

Require Export f ps . 

Require Export frac. 

Require Export z_mod_p. 

(** * I. Several basic lemmas *) 

Open Scope hz_scope. 

Lemma hzqrandnatsummationOr C m : hz ) ( x : hzneq m ) ( a : nat -> 
hz ) C upper ; nat ) ; hzremaindermod m x ( natsummationO upper a ) ~> 
hzremaindermod m x { natsummationO upper { fun n : nat 
hzremaindermod mx(an))). Proof. intros. induction 
upper, slmpl. rewrite hzremaindermoditerated. apply idpath. change ( 
hzremaindermod m x ( natsummationO upper a + a ( S upper ) ) "> 
hzremaindermod m x ( natsummationO upper ( fun n : nat => 
hzremaindermod mxCan)) + hzremaindermod m x ( a ( S upper ) ) ) 
) . rewrite hzremaindermodandplus . rewrite IHupper. rewrite <- ( 
hzremaindermoditerated m x ( a ( S upper ) ) ) . rewrite <- 
hzremaindermodandplus. rewrite hzremaindermoditerated. apply idpath. 
Defined. 

Lemma hzqrandnatsummationOq C m : hz ) C x : hzneq m ) ( a : nat -> 
hz ) C upper : nat ) ; hzquotientmod m x ( natsummationO upper a ) ~> 
C natsummationO upper ( fun n : nat hzquotientmod mxCan))+ 
hzquotientmod m x ( natsummationO upper ( fun n : nat => 
hzremaindermod mx (an) ) ) }. Proof, intros. induction 
upper, simpl. rewrite <- hzqrandremainderq. rewrite hzplusrO. apply 
idpath. change ( natsummationO ( S upper ) a ) with ( natsummationO 
upper a + a C S upper ) ), rewrite hzquotientmodandplus . rewrite 
IHupper. rewrite C hzplusassoc ( natsummationO upper ( fun n : nat => 
hzquotientmod mxCan)))_( hzquotientmod m x ( a ( S upper ) ) 
) ) . rewrite ( hzpluscorara ( hzquotientmod m x ( natsummationO upper ( 
fun n : nat => hzremaindermod mxCan)))) ( hzquotientmod m x ( 
a C S upper ) ) ) ) . rewrite <- C hzplusassoc ( natsummationO upper ( 
fun n : nat => hzquotientmod mxCan))) C hzquotientmod m x ( a ( 
S upper )))_). change ( natsummationO upper ( fun n : nat => 
hzquotientmod mxCan))+ hzquotientmod m x ( a ( S upper ) ) ) 
with C natsummationO ( S upper ) ( fun n : nat => hzquotientmod m x ( 
an))). 

rewrite hzqrandnatsummationOr. rewrite hzquotientmodandplus. 
rewrite <- hzqrandremainderq, rewrite hzpluslO . rewrite 
hzremaindermoditerated, rewrite ( hzplusassoc (natsummationO ( S upper 
) ( fun n : nat => hzquotientmod mx(an))) ( hzquotientmod m x ( 
natsummationO upper ( fun n : nat => hzremaindermod mx(an) ) ) ) 



_ ) . rewrite <- ( hzplusassoc ( hzquotientmod m x ( natsummationO 
upper C f im n : nat => hzremaindermod mx(an) )))__). 
rewrite <- ( hzquotientmodandplus ) , apply idpath. Defined. 

Lemma hzquotientandtimesl ( m : hz ) ( x : hzneq Om) (ab:hz) : 
hzquotientmod mxCa*b)~>(C hzquotientmod mxa) *b+( 
hzremaindermod mxa) * ( hzquotientmod m x b ) + hzquotientmod m x ( 
C hzremaindermod m x a ) * ( hzremaindermod m x b ) ) ) . Proof . 
intros . rewrite hzquotientmodandtimes . rewrite ( hzmultcomm ( 
hzremaindermod m x b ) ( hzquotientmod mxa) ) . rewrite 
hzmultassoc. rewrite <- C hzldistr C hzquotientmod mxb*m) _ C 
hzquotientmod mxa)). rewrite C hzmultcomm _ m ). rewrite <- C 
hzdivequationmod m x b ). rewrite hzplusassoc. apply idpath. 
Def ined . 

Lemma hzquotientandfpstimesl ( m : hz ) ( x : hzneq m ) ( a b : nat 
-> hz ) C upper : nat ) : hzquotientmod m x ( fpstimes hz a b upper ) 
~> C natsummationO upper ( fun i : nat => ( hzquotientmod m x C a i ) 
) * b C minus upper i ) ) + hzquotientmod m x ( natsummationO upper ( 
fun i : nat => ( hzremaindermod mxCai))*bC minus upper i ) ) 
) ) . Proof . intros . destruct upper . simpl . unfold 
fpstimes . simpl . rewrite hzquotientandtimesl . rewrite hzplusassoc . 
apply ( maponpaths ( fun v : _ => hzquotientmod m x ( a O'/oiat ) * b 
OVtuat V ) ) . rewrite ( hzquotientmodandtimes m x ( hzremaindermod m 
X ( a 0%nat ) ) C b 0°/Snat ) ), rewrite <- hzqrandremainderq. rewrite 
hzmultxO . rewrite 2 ! hzmultOx . rewrite hzpluslO . rewrite 
hzremaindermoditerated. apply idpath. unfold fpstimes . rewrite 
hzqrandnatsummationOq. assert ( forall n : nat, hzquotientmod m x (a n 
* b C minus C S upper ) n)%nat) ~> C ( hzquotientmod mxCan))*b 
C minus ( S upper ) n ) + ( hzremaindermod mxCan))*( 
hzquotientmod m x ( b ( minus ( S upper ) n ) ) ) + hzquotientmod m x 
( C hzremaindermod mxCan))*{ hzremaindermod m x { b { minus ( 
S upper )n))))))asf. intro k. rewrite hzquotientandtimesl, 
apply idpath. rewrite C natsummationpathsupperf ixed _ _ C fun xO p => 
f xO ) ) . rewrite ( natsummationplusdistr ( S upper ) ( fun xO : nat 
=> hzquotientmod m x (a xO) * b C minus C S upper ) xO)'/,nat + 
hzremaindermod m x (a xO) * hzquotientmod m x (b (S upper - xO)linat) ) 
) . rewrite ( natsummationplusdistr ( S upper ) ( fun xO : nat => 
hzquotientmod m x (a xO) * b (S upper - xO)°/,nat ) ). rewrite 2! 
hzplusassoc. apply ( maponpaths ( fun v : _ natsummationO ( S upper 
) C fun i : nat => hzquotientmod mxCai)*bC minus ( S upper ) i 
) ) + V ) ). rewrite C hzqrandnatsummationOq m x ( fun i : nat => 
hzremaindermod mx(ai)*bC minus ( S upper ) i ) ) ) . assert ( 
(natsummationO (S upper) (fun n : nat => hzremaindermod m x 
(hzremaindermod m x (a n) * b (S upper - n)7onat))) "> ( natsummationO 
( S upper ) ( fun n : nat => hzremaindermod mx(an*bC minus ( S 
upper )n)))))asg. apply natsummationpathsupperf ixed. intros j 
p . rewrite hzremaindermodandtimes . rewrite 

hzremaindermoditerated. rewrite <- hzremaindermodandtimes . apply 
idpath. rewrite g. rewrite <- hzplusassoc. assert ( natsummationO (S 
upper) (fun xO : nat hzremaindermod m x (a xO) * hzquotientmod m x 
(b (S upper - xO)°/,nat)) + natsummationO (S upper) (fun xO : nat => 
hzquotientmod m x (hzremaindermod m x (a xO) * hzremaindermod m x (b 
CS upper - xO)°/.nat))) ~> natsummationO (S upper) (fun n : nat => 
hzquotientmod m x (hzremaindermod m x (a n) * b (S upper - n)5Cnat)) ) 
as h. rewrite <- ( natsummationplusdistr ( S upper ) C fun xO : nat => 
hzremaindermod m x ( a xO ) * hzquotientmod m x ( b ( minus ( S upper 
) xO ) ) ) ) , apply natsummationpathsupperf ixed . intros j p. rewrite ( 
hzquotientmodandtimes m x ( hzremaindermod mx(aj)) ( (b( minus 
( S upper ) j ) ) ) ). rewrite <- hzqrandremainderq. rewrite 2! 
hzmultOx. rewrite hzmultxO. rewrite hzpluslO. rewrite 
hzremaindermoditerated. apply idpath. rewrite h. apply idpath. 
Def ined . 

Close Scope hz_scope . 



(** * II, The carrying operation and induced equivalence relation on 
formal power series *) 

□pen Scope rng_scope. 

Fixpoint precarry ( m : hz ) (is : hzneq m ) C a : fpscommmg hz ) 
C n : nat ) : hz := match n with I OJinat => a 0%nat I S n => a ( S n 
) + ( hzquotientmod m is ( precarry m is a n ) ) end. 

Definition carry ( m : hz ) ( is : hzneq m ) : fpscommmg hz -> 
fpscommmg hz := fun a : fpscommmg hz => fun n : nat => 
hzremaindermod m is ( precarry m is a n ) . 

(* precarry and carry are as described in the following example: 
CASE: mod 3 

First we normalize the sequence as we go along: 

5 6 8 4 (13) 2 2 ( remainder 2 mod 3 = 2 ) 4 1 ( remainder 13 mod 3 
= 1, quotient 13 mod 3=4) 22 C remainder 8 mod 3 = 
2, quotient 8 mod 3 = 2 ) 3 1 ( remainder 10 mod 3=1, 
quotient 10 mod 3 = 3 ) 3 C remainder 9 mod 3=0, 
quotient 9 mod 3 = 3 ) 2 2 ( remainder 8 mod 3=2, 
quotient 8 mod 3=2) 

2 2 1 2 1 2 

Next we first precarry and then carry; 

5 6 8 4 (13) 2 2 4 13 2 8 3 (10) 3 9 2 8 

2 8 9 (10) 8 (13) 2 < precarried sequence 

2 2 12 12 < carried sequence *) 

Lemma isapropcarryequiv ( m : hz ) (is : hzneq m ) ( a b : 
fpscommmg hz ) : isaprop ( ( carry m is a ) ~> ( carry m is b ) ), 
Proof. intros, apply ( fps hz ), Defined, 

Definition carryequivO ( m : hz ) ( is : hzneq m ) : hrel ( 
fpsconmimg hz ) := fun a b : fpscommmg hz => hProppair _ ( 
isapropcarryequiv m is a b ) . 

Lemma carryequiviseqrel ( m : hz ) (is : hzneq m ) : iseqrel ( 
carryequivO m is ) , Proof. intros. split, split, intros a b c i 
j. simpl. rewrite i. apply j. intros a. simpl. apply idpath. intros a 
b i. simpl. rewrite i. apply idpath. Defined. 

Lemma carryandremainder ( m : hz ) ( is : hzneq Cm) ( a : fpscommmg 
hz ) ( n : nat ) : hzremaindermod m is ( carry m is a n ) ~> carry m 
is an. Proof, intros. unfold carry, rewrite 
hzremaindermodit erated . apply idpath . Defined . 

Definition carryequiv ( m : hz ) ( is : hzneq Cm): eqrel ( 
fpscommmg hz ) := eqrelpair _ ( carryequiviseqrel m is ) . 

Lemma precarryandcarry ( m : hz ) ( is : hzneq m ) ( a : fpscommmg 
hz ) : precarry m is ( carry m is a ) ~> carry m is a. Proof, 
intros. assert ( forall n : nat, C precarry m is C carry m is a ) ) n 
~> C ( carry misa)n))asf. intros n. induction n. simpl. apply 
idpath. simpl, rewrite IHn. unfold carry at 2. rewrite <- 
hzqrandremainderq. rewrite hzplusrO. apply idpath. apply ( funextfun _ 
_ f ) . Defined. 

Lemma hzqrandcarryeq ( m : hz ) ( is : hzneq Cm) ( a : fpscommmg hz 



) ( n : nat ) : carry misan'>((m*0)+ carry m is a n ) . 
Proof. intros. rewrite hzmultxO. rewrite hzpluslO, apply idpath. 
Defined. 

Lemma hzqrandcarryineq ( m : hz ) (is : hzneq Cm) ( a : fpscommmg 
hz ) ( n : nat ) : dirprod ( hzleh ( carry m is a n ) ) ( hzlth ( 
carry m is a n ) ( nattohz ( hzabsval m ) ) ) . Proof . 
intros. split, unfold carry, apply ( pr2 ( prl ( divalgorithm ( 
precarry misan)mi&) ) ). unfold carry, apply ( pr2 ( prl ( 
divalgorithm ( precarry misan)mis))). Defined. 

Lemma hzqrandcarryq ( m : hz ) ( is : hzneq Cm) ( a : fpscommmg hz 
) ( n : nat ) : "> hzquotientmod m is ( car"ry m is a n ) , Proof, 
intros . apply ( hzqrtestq m is ( carry m is a n ) ( carry m is a n ) 
). split, apply hzqrandcarryeq. apply hzqrandcarryineq. Defined. 

Lemma hzqrandcarryr ( m : hz ) ( is : hzneq m ) ( a : fpscommmg hz 
) ( n : nat ) : caxry m is a n ~> hzremaindermod m is ( carry m is a n 
) . Proof . intros . apply ( hzqrtestr m is ( carry m is a n ) ( 
carry m is a n ) ). split, apply hzqrandcarryeq. apply 
hzqrandcarryineq. Defined, 

Lemma doublecarry ( m : hz ) ( is : hzneq m ) ( a : fpscommmg hz ) 
: carry m is ( carry m is a ) ~> carry m is a. Proof. intros. assert 
( forall n : nat , ( caxry m is ( caxry misa))n~>(( carry m is 
a ) n ) ) as f , intros. induction n. unfold caxry. simpl. apply 
hzremaindermoditerated. unfold carry, simpl, change (precarry m is 
(fun nO : nat => hzremaindermod m is (precarry m is a nO)) n) with ( ( 
precarry m is ( carry m is a ) ) n ) . rewrite 

precarryandcarry. rewrite <- hzqrandcarryq. rewrite hzplusrO. rewrite 
hzremaindermoditerated. apply idpath. apply ( funextfun _ _ f ). 
Def ined . 

Lemma carryandcarryequlv ( m : hz ) ( is : hzneq m ) ( a : 
fpscommmg hz ) : carryequiv m is ( carry m is a ) a. Proof, 
intros . simpl . rewrite doublecarry, apply idpath. Defined. 

Lemma quotientprecarryplus ( m : hz ) ( is : hzneq m ) ( a b : 
fpscommmg hz ) ( n : nat ) : hzquotientmod m is ( precarry m is ( a + 
b ) n ) ~> ( hzquotientmod m is ( precarry m is a n ) + hzquotientmod 
m is ( precarry m is b n ) + hzquotientmod m is ( precarry m is C 
carry m is a + carry m is b ) n ) ). Proof, intros. induction 
n. simpl. change ( hzquotientmod m is ( a OJinat + b Olinat ) ~> 
(hzquotientmod m is (a 0%nat) + hzquotientmod m is (b 07,nat) + 
hzquotientmod m is ( hzremaindermod m is ( a 07onat ) + hzremaindermod 
m is ( b O'/oiat ) ) ) ). rewrite hzquotientmodandplus . apply idpath. 

change ( hzquotientmod mis (a(Sn)+b(Sn)+ hzquotientmod 
m is ( precarry m is (a + b) n ) ) ~> (hzquotientmod m is (precarry 
m is a (S n)) + hzquotientmod m is (precarry m is b (S n)) + 
hzquotientmod m is (carry misa(Sn) + carry misb (Sn) + 
hzquotientmod m is ( precarry m is (carry m is a + carry m is b) n) ) 
) ). rewrite IHn. rewrite ( rngassocl hz(a(Sn))(b(Sn) 
) _ ) . rewrite <- ( rngassocl hz(b(Sn))). rewrite ( rngcomml 
hz(b(Sn))_). rewrite <- 3! C rngassocl hz(aCSn))_ 
_ ) . change ( a ( S n ) + hzquotientmod m is ( precarry m is a n ) 
) with ( precaxry misa(Sn) ). set ( pa := precaxry m is a ( S 
n ) ) . rewrite ( rngassocl hzpa_(b(Sn))). rewrite ( 
rngcomml hz_(b(Sn))). change ( b ( S n ) + hzquotientmod m 
is C precarry m is b n ) ) with ( precarry misbCSn) ). set C 
pb := precarry misb(Sn) ). set ( ab := precarry m is ( carry 
m is a + caxry m is b ) ). rewrite ( rngassocl hz ( caxry m is a ( 
S n ) ) ( carry misbCSn) ) ( hzquotientmod m is ( ab n ) ) ). 
rewrite ( hzquotientmodandplus m is ( caxry misa(Sn))_). 
unfold carry at 1. rewrite <- hzqrandremainderq. rewrite hzpluslO. 
rewrite ( hzquotientmodandplus m is ( carry misb (Sn) ) _). 



unfold carry at 1. rewrite <- hzqrandremainderq , rewrite hzpluslO. 
rewrite ( rngassocl hz pa pb _ ) . rewrite ( hzquotientraodandplus m 
is pa _ ) . change (pb + hzquotientraod m is (ab n)) with (pb + 
hzquotientmod m is (ab n))/ihz. rewrite ( hzquotientmodandplus m is 
pb ( hzquotientmod m is ( ab n ) ) ). rewrite <- 2! ( rngassocl hz 
C hzquotientmod m is pa ) _ _ ). rewrite <- 2! ( rngassocl hz ( 
hzquotientmod m is pa + hzquotientmod m is pb ) _ ) , rewrite 2! C 
rngassocl hz ( hzquotientmod m is pa + hzquotientmod m is pb + 
hzquotientmod m is (hzquotientmod m is (ab n)) ) _ _ ). apply ( 
maponpaths ( fun x : hz => ( hzquotientmod m is pa + hzquotientmod m 
is pb + hzquotientmod m is (hzquotientmod m is (ab n)) } + z ) ). 
unfold carry at 1 2. rewrite 2! hzremaindermoditerated . change ( 
precarry misb (Sn) ) with pb. change ( precarry m is a ( S n ) 
) with pa, apply ( maponpaths ( fun x : hz => ( hzquotientmod m is 
(hzremaindermod m is pb + hzremaindermod m is (hzquotientmod m is 
(ab n)))7,hz ) + x ) ). apply maponpaths. apply ( maponpaths ( fun x 
: hz => hzremaindermod m is pa + x ) ) . rewrite ( 
hzremaindermodandplus m is ( car-ry misb (Sn) ) unfold 
carry . rewrite hzremaindermoditerated. rewrite <- ( 
hzremaindermodandplus m is ( precarry misb (Sn) ) _). apply 
idpath . Def ined . 

Lemma carryandplus ( m : hz ) ( is : hzneq m ) ( a b : fpsconmirng hz 
) : carry m is ( a + b ) "> carry m is ( carry m is a + carry m is b 
). Proof. intros. assert ( forall n : nat, carry mis (a+b)n~> 
( carry m is ( carry m is a + carry misb)n))asf. intros 
n, destruct n, change ( hzremaindermod m is ( a 07,nat + b 0°/,nat ) ~> 
hzremaindermod m is ( hzremaindermod m is ( a 0/inat ) + hzremaindermod 
m is ( b O'/inaX ) ) ) . rewrite hzremaindermodandplus . apply idpath . 
change ( hzremaindermod mis (a(Sn)+b(Sn)+ hzquotientmod m 
is ( precarry mis(a+b)n))~> hzremaindermod m is ( 
hzremaindermod mis(a(Sn)+ hzquotientmod m is ( precarry m is a 
n ) ) + hzremaindermod mis(b(Sn)+ hzquotientmod m is ( 
precarry m is b n ) ) + hzquotientmod m is ( precarry m is ( carry m 
is a + carry misb)n) ) ). rewrite quotientprecarryplus . rewrite 
( hzremaindermodandplus m is ( hzremaindermod m is (a (S n) + 
hzquotientmod m is (precarry m is a n)) + hzremaindermod m is (b (S n) 
+ hzquotientmod m is (precarry m is b n)) ) _ ). change 
(hzremaindermod m is (a (S n) + hzquotientmod m is (precarry m is a 
n)) + hzremaindermod m is (b (S n) + hzquotientmod m is (precarry m is 
b n))) with (hzremaindermod m is (a (S n) + hzquotientmod m is 
(precarry m is a n))7orng + hzremaindermod m is Cb CS n) + 
hzquotientmod m is (precarry m is b n) ) y,mg) VJiz . rewrite <- 
(hzremaindermodandplus m is (a (S n) + hzquotientmod m is (precarry m 
is an)) (b (S n) + hzquotientmod m is (precarry m is b n) ) ). 
rewrite <- hzremaindermodandplus. change ( ((a (S n) + hzquotientmod 
m is (precarry m is a n))5img + (b (S n) + hzquotientmod m is 
(precarry m is b n))°/Srng + hzquotientmod m is (precarry m is (carry m 
is a + carry m is b)7»rng n))7»hz ) with ((a (S n) + hzquotientmod m is 
(precarry m is a n))7,rng + (b (S n) + hzquotientmod m is (precarry m 
is b n))%rng + hzquotientmod m is (precarry m is (carry m is a + carry 
m is b)%rng n))%mg. rewrite <- ( rngassocl hz(a(Sn) + 
hzquotientmod m is ( precarry m is a n ) ) (b (S n) ) ( hzquotientmod 
m is (precarry m is b n)) ). rewrite ( rngassocl hz(a(Sn))( 
hzquotientmod m is ( precarry misan) ) (b (Sn) ) ). rewrite ( 
mgcomml hz ( hzquotientmod m is ( precarry misan) ) (b(Sn) ) 
). rewrite <- 3! ( rngassocl hz ). apply idpath. apply ( funextfun _ 
_ f ) . Defined. 



Definition quotientprecarry ( m 
fpscommmg hz ) : fpscommrng hz 

precarry m is a x ) . 



: hz ) ( is : hzneq m ) ( a : 

:= fun X : nat => hzquotientmod m is ( 



Lemma quotientandtimesrearrangel ( m : hz ) ( is : hzneq m ) ( x y : 
hz ) : hzquotientmod mis(x*y)~>(( hzquotientmod m is x ) * y 
+ hzquotientmod m is ( ( hzremaindermod misx) *y) ). Proof . 



intros. rewrite hzquotientmodandtimes , change (hzquotientmod m is x * 
hzquotientmod m is y * m + hzremaindermod m is y * hzquotientmod m is 
X + hzremaindermod m is x * hzquotientmod m is y -*- hzquotientmod m is 
(hzremaindermod m is x * hzremaindermod m is y))>Oiz with 
(hzquotientmod m is x * hzquotientmod m is y * m ->- hzremaindermod m is 
y * hzquotientmod m is x + hzremaindermod m is x * hzquotientmod m is 
y + hzquotientmod m is (hzremaindermod m is x * hzremaindermod m is 
y))°/,rng. rewrite ( rngcomm2 hz ( hzremaindermod m is y ) ( 
hzquotientmod m is x ) ) , rewrite ( mgassoc2 hz ) , rewrite <- ( 
rngldistr hz ) . rewrite ( rngcomm2 hz ( hzquotientmod m is y ) m ) . 
change (m * hzquotientmod m is y -*- hzremaindermod m is y)*/,m^ with (m 
* hzquotientmod m is y + hzremaindermod m is y)%hz. rewrite <- ( 
hzdivequationmod m is y ) , change (hzremaindermod m is x * y)Xmg with 
(hzremaindermod m is x * y)°/,hz. rewrite ( hzquotientmodandtimes m is 
( hzremaindermod m is x ) y ) . rewrite 

hzremaindermoditerated. rewrite <- hzqrandremainderq. rewrite 
hzmultxO. rewrite 2! hzmultOx. rewrite hzpluslO. rewrite ( rngassocl 
hz ) , change (hzquotientmod m is x * y + (hzremaindermod m is x * 
hzquotientmod m is y + hzquotientmod m is (hzremaindermod m is x * 
hzremaindermod m is y))7»hz) with (hzquotientmod m is x * y + 
(hzremaindermod m is x * hzquotientmod m is y + hzquotientmod m is 
(hzremaindermod m is x * hzremaindermod m is y)))%mg. apply idpath. 
Defined. 

Lemma natsummationplusshift { R : commrng } ( upper : nat ) ( f g : 
nat -> R ) : ( natsummationO ( S upper ) f ) + ( natsummationO upper g 
) ~> ( f Oy,nat + ( natsummationO upper ( fun x : nat =>f(Sx)+g 
X ) ) ). Proof. intros. destruct upper, unfold 
natsummationO. simpl. apply ( rngassocl R ). rewrite ( 
natsummationshif to ( S upper ) f ) . rewrite ( mgcomml R _ ( f OXnat ) 
). rewrite ( rngassocl R ). rewrite natsummationplusdistr. apply 
idpath . Defined . 

Lemma precarryandtimesl ( m : hz ) (is: hzneq m ) ( a b : 
fpscommrng hz ) ( n : nat ) : hzquotientmod m is ( precarry m is (a * 

b ) n ) ~> ( ( quotientprecarry misa*b)n+ hzquotientmod m is ( 
precarry m is ( ( carry misa)*b)n)). Proof, 
intros. induction n. unfold precarry, change ( ( a * b ) 0°/,nat ) with 
( a oy,nat * b 0°/,nat ) , change ( ( quotientprecarry m is a * b ) 07,nat 
) with ( hzquotientmod m is ( a O^nat ) * b 0°/,nat ) , rewrite 
quotientandtimesrearrangel. change ( ( carry m is a * b ) 0%nat ) 
with ( hzremaindermod m is ( a Ot^nat ) * b O'^^nat ). apply idpath. 

change ( precarry mis(a*b)(Sn)) with ( (a*b) (Sn) 
+ hzquotientmod m is ( precarry mis(a*b)n)). rewrite 
IHn. rewrite <- ( rngassocl hz ). assert (((a*b)(Sn)+( 
quotientprecarry misa*b)n)*'>( Qop2 ( fpscommmg hz ) ( 
precarry misa)b) {Sn))asf. change ( {a*b) (Sn) ) 
with C natsummationO ( S n ) ( fun x : nat => a x * b ( minus ( S n 
) X ) ) ). change ( ( quotientprecarry misa*b)n) with ( 
natsummationO n ( fun x : nat => quotientprecarry m is a x * b ( 
minus n x ) ) ) . rewrite natsummationplusshift . change ( ( 3op2 ( 
fpscommimg hz ) ( precarry misa)b) (Sn) ) with ( 
natsummationO ( S n ) ( fun x : nat => ( precarry misa)x*b( 
minus (Sn)x))), rewrite natsummationshif tO . unfold precarry 
at 2. simpl. rewrite <- ( mgcomml hz ( a Oy,nat *b(Sn) )_ 
) , apply ( maponpaths ( fun x : hz => a 07»nat *b(Sn)+x) 
). apply natsummationpathsupperf ixed. intros k j. unfold 
quotientprecarry. rewrite ( rngrdistr hz ). apply idpath. rewrite 
f. rewrite hzquotientmodandplus. change C flop2 ( fpscommrng hz ) ( 
precarry m is a ) b ) with ( fpstimes hz ( precarry m is a ) b 
), rewrite ( hzquotientandf pstimesl m is ( precarry m is a ) b 
), change ( ©op2 ( fpscommrng hz ) ( carry m is a ) b ) with ( 
fpstimes hz ( carry m is a ) b ) at 1 . unfold fpstimes at 1 . unfold 
carry at 1 . change (fun nO : nat => let t ' : = fun mO : nat => b (nO 
- mO)7tnat in natsummationO nO (fun x : nat => (hzremaindermod m is 



(precarry m is a x) * t' x)°/,rng)) with ( carry m is a * b ) . change 
( C quotientprGcarry misa*b) (Sn)) with ( nat summat ionO ( S 
n ) C fun i : nat => hzquotientmod m is C precarry misai) *b( 
S n - i )yaiat ) ). rewrite 2! hzplusassoc. apply ( maponpaths ( fun 

V : _ => nat summat ionO ( S n ) { fun i : nat => hzquotientmod m is ( 
precarry misai) *b (Sn-i )°/,nat ) + v ) ). change C precarry 
m is ( carry misa*b) (Sn) ) with C ( carry raisa*b) (S 
n ) + hzquotientmod m is ( precarry m is C carry misa*b) n) ). 
change ((carry m is a * b) (S n) + hzquotientmod m is (precarry m is 
(carry m is a * b) n)) with ((carry m is a * b)%rng (S n) + 
hzquotientmod m is (precarry m is (carry m is a * b) n)'/,nig)Xhz. 
rewrite C hzquotientmodandplus m is ( ( carry misa*b) (Sn) ) 
( hzquotientmod m is ( precarry m is ( carry misa*b)n))). 
change ( ( carry misa*b) (Sn) ) with ( natsummationO ( S n ) 
( fun i : nat => hzremaindermod m is ( precarry misai)*b(Sn 
- i )*/jiat ) ). rewrite hzplusassoc. apply ( maponpaths ( fun v : _ 
=> ( hzquotientmod m is ( natsummationO ( S n ) ( fun i : nat => 
hzremaindermod m is ( precarry misai) *b (Sn-i )'/,nat ) ) ) 

+ V ) ) . apply ( maponpaths ( fun v : _ => hzquotientmod m is ( 
hzquotientmod m is ( precarry m is ( carry m is a * b )/irng n ) ) + 

V ) ) . apply maponpaths , apply ( maponpaths ( fun v : _ => v + 
hzremaindermod m is ( hzquotientmod m is ( precarry m is ( carry m 
is a * b )yjmg n ) ) ) ), unfold fpstimes. rewrite 
hzqrandnatsummationOr. rewrite ( hzqrandnat summat ionOr m is ( fun i 
: nat => hzremaindermod m is ( precarry misai)*b(Sn-i 
)'/,nat ) ). apply maponpaths. apply 

natsummationpathsupperf ixed. intros j p. change ( hzremaindermod m 
is (hzremaindermod m is (precarry misaj) *b ( minus ( S n ) j)) 
) with ( hzremaindermod m is (hzremaindermod m is (precarry m is a 
j) * b (S n - j)Iinat)yjiz ). rewrite ( hzremaindermodandt imes m is ( 
hzremaindermod m is ( precarry misaj)) (b( minus ( S n ) j ) 
) ) . rewrite hzremaindermoditerated. rewrite <- 
hzremaindermodandt ime s . apply idpath . Def ined . 

Lemma carryandt imesl ( m : hz ) (is : hzneq m ) ( a b : fpscommmg 

hz ) ; carry m is ( a * b ) ~> carry m is ( carry m is a * b ). 
Proof, intros, assert ( forall n : nat, carry mis (a*b)n~> 
carry m is ( carry misa*b)n)asf. intros n. destruct n. unfold 
carry at 1 2. change ( precarry m is ( a * b ) 07,nat ) with ( a OXnat 
* b O^at ) . change ( precarry m is ( carry m is a * b ) 0°/,nat ) with 
( carry m is a O'/oiat * b 0%nat ). unfold carry, change (hzremaindermod 
m is (precarry m is a 0) * b OVinat) with (hzremaindermod m is 
(precarry m is a 0) * b Oyjiat )°/Shz. rewrite ( hzremaindermodandt imes 
m is ( hzremaindermod m is ( precarry m is a O^nat ) ) ( b O'/nat ) ) . 
rewrite hzremaindermoditerated, rewrite <- 

hzremaindermodandtimes , change ( precarry m is a OVoiat ) with ( a 
0%nat ). apply idpath. unfold carry at 1 2. change ( precarry m is ( a 
*b) (Sn)) with ((a*b)(Sn)+ hzquotientmod m is ( 
precarry mis (a*b)n) ). rewrite precarryandtimesl . rewrite <- ( 
rngassocl hz ), rewrite hzremaindermodandplus , assert ( hzremaindermod 
mis((a*b)(Sn)+( quotientprecarry misa*b)n) ~> 
hzremaindermod m is ( ( carry misa*b) (Sn)))asg. change ( 
hzremaindermod m is ( ( natsummationO ( S n ) ( fun u : nat => a u * b 
( minus (Sn)u)))+( natsummationO n ( fun u : nat => ( 
quotientprecarry mlsa)u*b( minus n u ) ) ) ) "> hzremaindermod 
m is ( natsummationO ( S n ) ( fun u : nat => ( carry misa)u*b( 
minus (Sn)u) ) ) ). rewrite ( nat summat ionplusshift n ) . rewrite 
( natsummationshif to n ( fun u : nat => carry m is a u * b ( minus ( S 
n ) u ) ) ) . assert ( hzremaindermod m is ( natsummationO n ( fun x : 
nat =>a(Sx) *b( minus (Sn)(Sx))+ quotientprecarry m is 
a X * b ( minus n x ) ) ) ~> hzremaindermod m is (natsummationO n ( 
fun X : nat => carry misa(Sx)*b( minus (Sn)(Sx)))) 
) as h. rewrite hzqrandnatsummationOr. rewrite ( hzqrandnatsummationOr 
m is ( fim X : nat => carry misa(Sx)*b( minus (Sn) (Sx) 
) ) ). apply maponpaths. apply natsummationpathsupperf ixed. intros j 
p. unfold quotientprecarry. simpl. change (a (S j) * b ( minus n j) + 



hzquotientmod m is (precarry misaj)*b( minus n j)) with (a (S j) 
* b ( minus n j) + hzquotientmod m is (precarry misaj) *b ( minus 
n j) y/,hz. rewrite <- ( hzrdistr (a(Sj)) ( hzquotientmod m is ( 
precarry misaj)) (b( minus n j ) ) ) . rewrite 

hzremaindermodandtimes. change C hzremaindermod m is (hzremaindermod m 
is (a (S j) + hzquotientmod m is (precarry m is a j)) * hzremaindermod 
m is (b ( minus n j))) ~> hzremaindermod m is (carry m is a (S j) * b 
(minus n j)) )°/,rng. rewrite <- ( hzremaindermoditerated m is (a (S j) 
+ hzquotientmod m is (precarry m is a j)) ), unfold carry, rewrite <- 
hzremaindermodandtimes. apply idpath. rewrite 
hzremaindermodandplus • rewrite h. rewrite <- 
hzremaindermodandplus. unfold carry at 3. rewrite ( 

hzremaindermodandplus m is _ ( hzremaindermod m is ( precarry m is a 
0°/,nat ) * b ( minus ( S n ) 0°/,nat ) ) ) , rewrite 

hzremaindermodandtimes . rewrite hzremaindermoditerated, rewrite <- 
hzremaindermodandtimes. change ( precarry m is a 0>^at ) with ( a 
O'^inat ). rewrite <- hzremaindermodandplus. rewrite hzpluscomm. apply 
idpath. rewrite g. rewrite <- hzremaindermodandplus. apply 
idpath. apply ( funextfun _ _ f ). Defined. 

Lemma carryandtimesr ( m : hz ) ( is : hzneq m ) ( a b : fpscommmg 
hz ) : carry m is ( a * b ) ~> carry m is (a * carry m is b ) . 
Proof. intros. rewrite ( Qrngcomm2 ( fpscommmg hz ) ) . rewrite 
carryandtimesl. rewrite ( Qrngcomm2 ( fpscommmg hz ) ) . apply 
idpath . Def ined . 

Lemma carryandtimes ( m : hz ) ( is : hzneq m ) ( a b : fpscommmg 
hz ) : carry m is ( a * b ) ~> carry m is ( carry m is a * carry m is 
b ) . Proof . intros . rewrite carryandtimesl . rewrite 
carryandtimesr. apply idpath. Defined. 

Lemma mgcarryequiv ( m : hz ) ( is : hzneq m ) : Qrngeqrel ( 
fpscommmg hz ). Proof. intros. split with ( carryequiv m is 
). split, split, intros a b c q. simpl. simpl in q. rewrite 
carryandplus . rewrite q. rewrite <- carryandplus . apply idpath. intros 
a b c q. simpl. rewrite carryandplus, rewrite q, rewrite <- 
carryandplus. apply idpath, split, intros a b c q. simpl. rewrite 
carryandtimes . rewrite q. rewrite <- carryandtimes . apply 
idpath. intros a b c q. simpl. rewrite carryandtimes. rewrite 
q. rewrite <- carryandt imes . apply idpath . Defined . 

Definition commrngof padicints ( p : hz ) ( is : isaprime p ) := 
commrngquot ( mgcarryequiv p ( isaprimetoneqO is ) ) . 

Definition padicplus ( p : hz ) ( is : isaprime p ) := Qopl ( 
commrngofpadicints p is ) . 

Definition padictimes ( p : hz ) ( is : isaprime p ) := 9op2 ( 
commrngofpadicints p is ) , 

(** * III. The apartness relation on p-adic integers *) 

Definition padicapartO ( p : hz ) ( is ; isaprime p ) : hrel ( 
fpscommmg hz ) := fun a b : _ => ( hexists ( fun n ; nat => ( neq _ ( 
carry p ( isaprimetoneqO is) a n ) ( carry p ( isaprimetoneqO is ) b n 

) ) ) ). 

Lemma padicapartiscomprel ( p : hz ) ( is ; isaprime p ) : 

iscomprelrel ( carryequiv p ( isaprimetoneqO is ) ) ( padicapartO p is 

). Proof, intros pisaa'bb' ij. apply uahp. intro k. apply 

k. intros u. destruct u as [ n u ]. apply total2tohexists. split with 

n. rewrite <- i , <- j . assumption. intro k. apply k. intros 

u. destruct u as [ n u ], apply total2tohexists . split with n. rewrite 

i, j . assumption. Defined. 

Definition padicapartl ( p : hz ) ( is : isaprime p ) : hrel ( 



commiTigofpadicints p is ) := quotrel ( padicapartiscomprel p is ) . 

Lemma isirref IpadicapartO ( p : hz ) ( is : isaprime p ) : isirrefl ( 
padicapartO p is ) . Proof, intros. intros a f. simpl in f. assert 
hfalse as x. apply f. intros u. destruct u as [ n u ]. apply u. apply 
idpath. apply x. Defined. 

Lemma issymmpadicapartO ( p : hz ) C is : isaprime p ) ; issymm C 
padicapartO p is ) , Proof , intros . intros a b f , apply f . intros 
u. destruct u as [ n u ]. apply total2tohexists , split with n, intros 
g. apply u. rewrite g. apply idpath. Defined. 

Lemma iscotranspadicapartO ( p ; hz ) C is ; isaprime p ) : iscotreins 
( padicapartO p is ) . Proof. intros, intros a b c f. apply f. intros 
u. destruct u as [ n u ]. intros P j. apply j. destruct ( isdeceqhz ( 
carry p ( isaprimetoneqO is ) a n ) C carry p C isaprimetoneqO is ) b 
n))as[l|r]. apply ii2. intros Q k. apply k. split with 
n. intros g. apply u. rewrite 1, g. apply idpath. apply iil. intros Q 
k. apply k. split with n. intros g. apply r. assumption. Defined. 

Definition padicapart ( p ; hz ) ( is : isaprime p ) : apairt C 
commrngofpadicints p is ) . Proof. intros, split with C padicapartl p 
is ) . split, unfold padicapartl. apply C isirref Iquotrel ( 
padicapartiscomprel p is ) ( isirref IpadicapartO p is ) 
) . split . apply ( issymmquotrsl ( padicapart iscompr si p is ) ( 
issymmpadicapartO p is ) ) . apply ( iscotransquotrel ( 
padicapartiscomprel p is ) ( iscotranspadicapartO p is ) ). Defined. 

Lemma precarryandzero ( p : hz ) ( is : isaprime p ) : precarry p ( 
isaprimetoneqO is ) "> ( flmgunell ( fpsconmirng hz ) ) . Proof . 
intros, assert ( forall n : nat , precarry p C isaprimetoneqO is ) n 
~> ( ©rngunell (fpscommrng hz ) ) n ) as f . intros n. induction 
n. unfold precarry. change ( ( Orngunell ( fpscommrng hz ) ) 0/inat ) 
with 0'/,hz. apply idpath. change C C C Qmgunell ( fpscommrng hz ) ( S 
n ) + hzquotientmod p ( isaprimetoneqO is ) ( precarry p ( 
isaprimetoneqO is ) ( Qrngunell ( fpscommrng hz ) ) n ) ) ) ~> O'/hz 
), rewrite IHn. change C ( Srngunell { fpscommrng hz ) ) n ) with 
0%hz. change ( ( Orngunell ( fpscommrng hz)) (Sn)) with 0°/,hz. 
rewrite hzqrandOq. rewrite hzpluslO. apply idpath. apply ( funextfun 
f ) . Defined. 

Lemma carryandzero ( p : hz ) ( is : isaprime p ) : carry p ( 
isaprimetoneqO is ) "> 0. Proof. intros. unfold carry, rewrite 
precarryandzero. assert C forall n ; nat, (fun n : nat => 
hzremaindermod p (isaprimetoneqO is) ( ( ©rngunell ( fpscommrng hz ) ) 
n)) n ~> ( Srngunell ( fpscommrng hz ) ) n ) as f , intros n. rewrite 
hzqrandOr. unfold carry, change C ( Qrngunell ( fpscommrng hz ) n ) ) 
with 0%hz. apply idpath. apply ( funextfun _ _ f ). Defined. 

Lemma precarryandone ( p : hz ) ( is : isaprime p ) : precarry p ( 
isaprimetoneqO is ) 1 ~> ( 9rngunel2 ( fpscommrng hz ) ) , Proof, 
intros. assert C forall n : nat, precarry p ( isaprimetoneqO is ) 1 n 
~> C <3mgunel2 (fpscommrng hz ) ) n ) as f . intros n. induction 
n, unfold precarry. apply idpath. simpl, rewrite IHn. destruct 
n, change ( ( (9rngunel2 ( fpscommrng hz ) ) OXnat ) with l%hz. rewrite 
hzqrandlq. rewrite hzplusrO. apply idpath. change ( ( Srngunel2 ( 
fpscomming hz))(Sn)) with OVthz. rewrite hzqrandOq. rewrite 
hzplusrO. apply idpath. apply { funextfun _ _ f ). Defined. 

Lemma carryandone ( p : hz ) ( is : isaprime p ) : carry p ( 
isaprimetoneqO is ) 1 "> 1. Proof. intros. unfold carry, rewrite 
precarryandone, assert ( forall n ; nat, (fun n ; nat => 
hzremaindermod p (isaprimetoneqO is) ( ( @rngunel2 ( fpscommrng hz ) ) 
n)) n ~> ( Srngunel2 ( fpscommrng hz ) ) n ) as f , intros n. destruct 
n. change ( ( Smgunel2 ( fpscommrng hz ) ) OVtUat ) with 
l%hz. rewrite hzqrandlr. apply idpath. change ( ( 3mgunel2 ( 



fpsconmirng hz)) (Sn)) with 0%hz, rewrite hzqrandOr. apply 
idpath. apply ( funextfun _ _ f ). Defined, 

Lenmia padicapart computation ( p : hz ) ( is : isaprime p ) ( a b : 
fpscommrng hz ) : ( prl ( padicapart p is ) ) ( setquotpr (carryequiv 
p ( isaprimetoneqO is ) ) a ) ( setquotpr ( carryequiv p C 
isaprimetoneqO is ) ) b ) ~> padicapartO p is a b. Proof, 
intros. apply uahp. intros i. apply i, intro u, apply u. Defined, 

Lenmia padicapartandplusprecarryl ( p : hz ) ( is : isaprime p ) ( a b 
c : fpscommrng hz ) ( n : nat ) ( x : neq _ ( precarry p ( 
isaprimetoneqO is ) ( carry p ( isaprimetoneqO is ) a + carry p ( 
isaprimetoneqO is)b)n) (( precarry p ( isaprimetoneqO is ) ( 
carry p ( isaprimetoneqO is ) a + carry p ( isaprimetoneqO is ) c ) ) 
n ) ) : ( padicapartO p is ) b c. Proof. intros. set ( P := fun x : 
nat => neq hz (precarry p (isaprimetoneqO is) (carry p (isaprimetoneqO 
is) a + carry p (isaprimetoneqO is) b) x) (precarry p (isaprimetoneqO 
is) (carry p (isaprimetoneqO is) a + carry p (isaprimetoneqO is) c) x) 
). assert ( isdecnatprop P ) as isdec, intros m. destruct ( isdeceqhz 
(precarry p (isaprimetoneqO is) (carry p (isaprimetoneqO is) a + carry 
p (isaprimetoneqO is) b) m) (precarry p (isaprimetoneqO is) (carry p 
(isaprimetoneqO is) a + carry p (isaprimetoneqO is) c) m) ) as [ 1 I r 
]. apply ii2. intros j. apply j. assumption, apply iil. assumption, 
set ( leexists := least element principle n P isdec x ). apply 
leexists. intro k. destruct k as [ k k' ]. destruct k' as [ k' k'' ]. 
destruct k. apply total2tohexists , split with 0%nat, intros i. apply 
k' . change (carry p (isaprimetoneqO is) a 0%nat + carry p 
(isaprimetoneqO is) b 05inat ~> (carry p (isaprimetoneqO is) a 0%nat + 
carry p (isaprimetoneqO is) c O'^^nat) ). rewrite i. apply idpath. 
apply total2tohexists . split with ( S k ). intro i. apply ( k' ' k 
). apply natlthnsn. intro j. apply k* . change ( carry p ( 
isaprimetoneqO is)a(Sk)+ carry p ( isaprimetoneqO is ) b ( S k 
) + hzquotientmod p ( isaprimetoneqO is ) ( precarry p ( 
isaprimetoneqO is ) ( carry p ( isaprimetoneqO is ) a + carry p ( 
isaprimetoneqO is ) b ) k ) ~> ( carry p ( isaprimetoneqO is ) a ( S k 
) + carry p ( isaprimetoneqO is)c(Sk)+ hzquotientmod p ( 
isaprimetoneqO is ) ( precarry p ( isaprimetoneqO is ) ( carry p ( 
isaprimetoneqO is ) a + carry p ( isaprimetoneqO is)c)k))). 
rewrite i . rewrite j , apply idpath. Defined, 

Lemma padicapart andplusprecarryr ( p : hz ) ( is : isaprime p ) ( a b 
c : fpscommrng hz ) ( n : nat ) ( x : neq _ ( precarry p ( 
isaprimetoneqO is ) ( carry p ( isaprimetoneqO is ) b + carry p ( 
isaprimetoneqO is)a)n)(( precarry p ( isaprimetoneqO is ) ( 
carry p ( isaprimetoneqO is ) c + carry p ( isaprimetoneqO is ) a ) ) 
n ) ) : ( padicapartO p is ) b c. Proof. intros. rewrite 2! ( 
rngcomml ( fpscommrng hz ) _ ( carry p ( isaprimetoneqO is ) a ) ) in 
X. apply ( padicapartandplusprecarryl pisabcnx). Defined. 

Lemma commmgquotprandopl { A : commrng } ( R : Srngeqrel A ) ( a b : 
A ) : ( @opl ( commrngquot R ) ) ( setquotpr ( prl R ) a ) ( setquotpr 
( prl R ) b ) ~> setquotpr ( prl R ) ( a + b ) , Proof , 
intros. change ( Qopl ( commrngquot R ) ) with ( setquotfun2 R R ( 
flopl A ) ( prl ( iscomp2binoptransrel ( prl R ) ( eqreltrans _ ) ( pr2 
R ) ) ) ). unfold setquotfun2. rewrite setquotuniv2comm. apply 
idpath. Defined. 

Lemma commmgquotprandop2 { A : commrng } ( R : Qrngeqrel A ) ( a b : 
A ) : ( Qop2 ( commrngquot R ) ) ( setquotpr ( prl R ) a ) ( setquotpr 
( prl R ) b ) ~> setquotpr ( prl R ) ( a * b ). Proof, 
intros . change ( Sop2 ( commrngquot R ) ) with ( setquotf un2 R R ( 
©op2 A ) ( pr2 ( iscomp2binoptransrel ( prl R ) ( eqreltrans _ ) ( pr2 
R ) ) ) ). unfold setquotf un2. rewrite setquotuniv2comm. apply 
idpath . Defined . 



Lemma setquotprandpadicplus { p : hz ) C is : isaprime p ) ( a b : 
fpscommrng hz ) : C Qopl C commrngofpadicints p is ) ) ( setquotpr ( 
carryequiv p C isaprimetoneqO is ) ) a ) ( setquotpr ( carryequiv p ( 
isaprimetoneqO is ) ) b ) ~> setquotpr ( carryequiv p C isaprimetoneqO 
is) ) (a+b). Proof. intros. apply commrngquotprandopl . 
Defined. 

Lemma setquotprandpadictimes ( p : hz ) ( is : isaprime p ) Cab: 
fpscommrng hz ) : ( Qop2 ( commrngofpadicints p is ) ) ( setquotpr ( 
carryequiv p ( isaprimetoneqO is ) ) a ) ( setquotpr ( carryequiv p ( 
isaprimetoneqO is ) ) b ) "> setquotpr ( carryequiv p ( isaprimetoneqO 
is) ) Ca*b). Proof, intros. apply commmgquotprandop2 . 
Defined. 



Lemma padicplusisbinopapartO ( p : hz ) (is : isaprime p ) ( a b c : 
fpscommrng hz ) ( u : padicapartO p is (a+b) (a+c)) : 
padicapartO p is b c. Proof. intros, apply u. intros n, destruct n 
as [ n n' ] , set C P fun x : nat neq hz C carry p C 
isaprimetoneqO is ) ( a + b) x) ( carry p ( isaprimetoneqO is ) ( a + 
c) x) ), assert ( isdecnatprop P ) as isdec. intros m. destruct ( 
isdeceqhz ( carry p ( isaprimetoneqO is ) ( a + b) m) ( carry p ( 
isaprimetoneqO is ) ( a + c) m) ) as [1 I r ]. apply ii2. intros 
j. apply j. assumption, apply iil. assumption. 

set C le := leastelementprinciple n P isdec n'). apply le. intro 
k. destruct k as [ k k' ]. destruct k' as [ k' k' ' ]. destruct k. 
apply total2tohexists . split with 0/inat . intros j. apply k' . unfold 
carry, unfold precarry. change ( ( a + b ) O^inat ) vith ( a OXnat 
+ b Oyoiat ) . change ( ( a + c ) 0%nat ) with ( a 0%nat + c 0%nat 
). unfold car-ry in j. unfold precarry in j. rewrite 
hzremaindermodandplus . rewrite j . rewrite <- 
hzremaindermodandplus . apply idpath. 

destruct ( isdeceqhz ( carry p ( isaprimetoneqO is)b(Sk)) ( 
carry p ( isaprimetoneqO is)c(Sk)) )as [1 |r]. apply ( 
padicapartandplusprecarryl p is a b c k ) . intros j . apply 
k' . rewrite ( carryandplus ). unfold carry at 1. change ( 
hzremaindermod p ( isaprimetoneqO is ) ( carry p ( isaprimetoneqO is 
) a C S k ) + carry p ( isaprimetoneqO is)b(Sk)+ 
hzquotientmod p ( isaprimetoneqO is ) ( precarry p ( isaprimetoneqO 
is ) ( carry p ( isaprimetoneqO is ) a + carry p ( isaprimetoneqO is 
) b ) k ) ) "> car"ry p ( isaprimetoneqO is) (a+c) (Sk) ). 
rewrite 1 . rewrite j , rewrite ( carryandplus p ( isaprimetoneqO is ) 
a c ). unfold carry at 5. change ( precarry p ( isaprimetoneqO is ) 
( carry p ( isaprimetoneqO is ) a + carry p ( isaprimetoneqO is ) c 
) ( S k ) ) with ( carry p ( isaprimetoneqO is)a(Sk)+ carry p 
( isaprimetoneqO is)c(Sk)+ hzquotientmod p ( isaprimetoneqO 
is ) ( precar"ry p ( isaprimetoneqO is ) ( car-ry p ( isaprimetoneqO 
is ) a + carry p ( isaprimetoneqO is ) c ) k ) ) . apply idpath. 
apply total2tohexists . split with ( S k ), assumption. Defined. 

Lemma padicplusisbinopapartl ( p : hz ) (is : isaprime p ) ; 
isbinopapartl ( padicapart p is ) ( padicplus p is ) . Proof, 
intros. unfold isbinopapartl. assert ( forall x x' x' ' : 
commrngofpadicints p is, isaprop ( ( prl ( padicapart p is ) ) ( 
padicplus p is X x' ) ( padicplus p is x x'' ) -> ( ( prl ( padicapart 
p is ) ) x' x' ' ) ) ) as int. intros. apply impred. intros. apply ( 
prl ( padicapart p is ) ). apply ( setquotuniv3prop _ ( fun x x' x' ' 
=> hProppair _ ( int z x' x** ) ) ). intros a b c. change (prl 
(padicapart p is) (padicplus p is (setquotpr (rngcarryequiv p 
(isaprimetoneqO is) ) a) (setquotpr (rngcarryequiv p (isaprimetoneqO 
is) ) b) ) (padicplus p is (setquotpr (rngcarryequiv p (isaprimetoneqO 
is) ) a) (setquotpr (rngcarryequiv p (isaprimetoneqO is) ) c) ) -> prl 
(padicapart p is) (setquotpr (rngcarryequiv p (isaprimetoneqO is)) b) 
(setquotpr (rngcarryequiv p (isaprimetoneqO is)) c)) . unfold 



padicplus . rewrite 2 ! setquotprandpadicplus . rewrite 2 ! 
padicapartcomputation . apply padicplusisbinopapartO . Defined, 

Lemma padicplus isbinopapartr ( p : hz ) ( is : isaprime p ) : 
isbinopapartr ( padicapart p is ) ( padicplus p is ) . Proof , 
intros. unfold isbinopapartr, intros a b c, unfold padicplus, rewrite 
C Qrngcomml ( commrngofpadicints p is ) b a ) . rewrite ( Srngcomml ( 
commrngofpadicints p is ) c a ). apply padicplusisbinopapartl. 
Def ined . 

Lemma padicapartandtimesprecarryl ( p : hz ) ( is : isaprime p ) ( a b 
c : fpscommrng hz ) ( n : nat ) ( x : neq _ ( precarry p ( 
isaprimetoneqO is ) ( carry p ( isaprimetoneqO is ) a * carry p ( 
isaprimetoneqO is)b)n) (( precar-ry p ( isaprimetoneqO is ) ( 
carry p ( isaprimetoneqO is ) a * carry p ( isaprimetoneqO is ) c ) ) 
n ) ) : ( padicapartO p is ) be. Proof, intros. set ( P := fun x : 
nat => neq hz (precarry p (isaprimetoneqO is) (carry p (isaprimetoneqO 
is) a + carry p (isaprimetoneqO is) b) x) (precarry p (isaprimetoneqO 
is) (carry p (isaprimetoneqO is) a * carry p (isaprimetoneqO is) c) x) 
). assert ( isdecnatprop P ) as isdec, intros m. destruct ( isdeceqhz 
(precarry p (isaprimetoneqO is) (carry p (isaprimetoneqO is) a * carry 
p (isaprimetoneqO is) b) m) (precarry p (isaprimetoneqO is) (carry p 
(isaprimetoneqO is) a * carry p (isaprimetoneqO is) c) m) ) as [ 1 I r 
] . apply ii2. intros j. apply j . assumption, apply iil. assumption, 
set ( leexists := leastelementprinciple n P isdec x ), apply 
leexists. intro k, destruct k as [ k k' ]. destruct k' as [ k' k' ' 
]. induction k. apply total2tohexists . split with 0°/,nat . intros i. 
apply k' , change (carry p (isaprimetoneqO is) a Oiinat * carry p 
(isaprimetoneqO is) b O'/nat ~> (carry p (isaprimetoneqO is) a 0°/«nat * 
carry p (isaprimetoneqO is) c 0/inat) ). rewrite i. apply idpath. set 
( Q := ( fim o ; nat => hProppair ( carry p ( isaprimetoneqO is ) b o 
"> carry p ( isaprimetoneqO is ) c o ) ( isasethz _ _ ) ) ) . assert ( 
isdecnatprop Q ) as isdec'. intro o. destruct ( isdeceqhz ( carry p ( 
isaprimetoneqO is ) b o ) ( carry p ( isaprimetoneqO is ) c o ) ) as [ 
1 I r ]. apply iil. assumption, apply ii2. assumption. destruct ( 
isdec isbndqdec Q isdec' (Sk))as[l|r]. assert hfalse as 
XX. apply ( k' ' k ) , apply natlthnsn. intro j. apply k' , change ( ( 
natsummationO ( S k ) ( fun x : nat => carry p ( isaprimetoneqO is ) a 
X * carry p ( isaprimetoneqO is ) b ( minus (Sk)x)))+ 
hzquotientmod p ( isaprimetoneqO is ) ( precarry p ( isaprimetoneqO is 
) ( carry p ( isaprimetoneqO is ) a * carry p ( isaprimetoneqO is ) b 
) k ) ~> (( natsummationO C S k ) ( fun x : nat => carry p ( 
isaprimetoneqO is ) a x * carry p ( isaprimetoneqO is ) c ( minus ( S 
k ) X ) ) ) + hzquotientmod p ( isaprimetoneqO is ) ( precar-ry p ( 
isaprimetoneqO is ) ( carry p ( isaprimetoneqO is ) a * carry p ( 
isaprimetoneqO is)c)k))). assert ( natsummationO ( S k ) (fun 
xO : nat => carry p (isaprimetoneqO is) a xO * carry p (isaprimetoneqO 
is) b ( minus ( S k ) xO)) ~> natsummationO ( S k ) (fun xO : nat => 
carry p (isaprimetoneqO is) a xO * carry p (isaprimetoneqO is) c ( 
minus ( S k ) xO)) ) as f. apply natsummationpathsupperf ixed. intros m 
y. rewrite ( 1 ( minus ( S k ) m ) ). apply idpath. apply 
minus leh. rewrite f . rewrite j , apply idpath. contradiction. 

apply r . intros o . destruct o as [ o o ' ] . apply 
total2tohexists . split with o. apply o' . Defined. 

Lemma padictimesisbinopapartO ( p : hz ) ( is ; isaprime p ) ( a b c : 
fpscommrng hz ) ( u : padicapartO pis(a*b)(a*c)): 
padicapartO p is b c. Proof. intros. apply u. intros n. destruct n 
as [ n n' ]. destruct n. apply total2tohexists . split vith 
OUnat. intros j . apply n' . rewrite carryandtimes . rewrite ( 
carryandtimes p ( isaprimetoneqO is ) a c ) , change ( hzremaindermod p 
( isaprimetoneqO is ) ( carry p ( isaprimetoneqO is ) a 0°/,nat * carry 
p ( isaprimetoneqO is ) b 0/inat ) ~> hzremaindermod p ( isaprimetoneqO 
is ) C carry p ( isaprimetoneqO is ) a OVjiat * carry p ( 
isaprimetoneqO is ) c O'^^nat ) ). rewrite j. apply idpath. set ( Q : = 



C fun o ; nat hProppair ( carry p ( isaprimetoneqO is ) b o "> 
carry p C isaprimGtoneqO is ) c o ) ( isasethz _ _ ) ) ) . assert ( 
isdecnatprop Q ) as isdec' . intro o. destruct C isdeceqhz ( carry p ( 
isaprimetoneqO is ) b o ) ( carry p ( isaprimetoneqO is)co))as[ 
1 I r ]. apply iil . assumption, apply ii2, assumption, destruct ( 
isdecisbndqdec Q isdec' ( Sn))as[l|r]. apply C 
padicapartandtimesprecarryl p is a b c n ) . intros j . assert hf alse as 
XX, apply n' . rewrite carryandtimes . rewrite ( carryEindtimes p C 
isaprimetoneqO is ) a c ) . change ( hzremaindermod p ( isaprimetoneqO 
is ) C nat summat ionO ( S n ) ( fun x : nat => carry p ( isaprimetoneqO 
is ) a X * carry p ( isaprimetoneqO is ) b ( minus CSn)x))+ 
hzquotientmod p ( isaprimetoneqO is ) ( precarry p ( isaprimetoneqO is 
) ( carry p ( isaprimetoneqO is ) a * carry p ( isaprimetoneqO is ) b 
) n ) ) ~> ( hzremaindermod p ( isaprimetoneqO is ) C natsuraraationO ( 
S n ) ( fun X : nat => carry p ( isaprimetoneqO is ) a x * carry p ( 
isaprimetoneqO is ) c ( minus (Sn)x))+ hzquotientmod p C 
isaprimetoneqO is ) C precarry p C isaprimetoneqO is ) ( carry p ( 
isaprimetoneqO is ) a * carry p ( isaprimetoneqO is)c)n)))). 
rewrite j, assert C natsummationO ( S n ) (fun xO : nat => carry p 
(isaprimetoneqO is) a xO * carry p (isaprimetoneqO is) b ( minus ( S n 
) xO)) ~> natsummationO ( S n ) (fun xO : nat => carry p 
(isaprimetoneqO is) a xO * carry p (isaprimetoneqO is) c ( minus ( S n 
) xO)) ) as f. apply natsummationpathsupperf ixed. intros m y. rewrite 
( 1 ( minus ( S n ) m ) ). apply idpath. apply minusleh. rewrite 
f, apply idpath. contradiction, apply r. intros k. destruct k as [ k 
k' ]. apply total2tohexists . split with k. apply k' . Defined, 

Lemma padictimesisbinopapartl ( p : hz ) ( is : isaprime p ) : 
isbinopapartl C padlcapart p is ) C padictimes p is ) . Proof, 
intros. unfold isbinopapartl. assert ( forall x x' x' ' : 
commrngof padicints p is, isaprop ( ( prl ( padicapart p is ) ) ( 
padictimes p is x x' ) ( padictimes p is x x'' ) -> ( ( prl ( 
padicapart p is ) ) x' x'' ) ) ) as int. intros. apply 
impred. intros. apply ( prl ( padicapart p is ) ). apply ( 
setquotuniv3prop _ ( fun x x' x'' => hProppair _ ( int x x* x** ) ) 
), intros a b c, change (prl (padicapart p is) (padictimes p is 
(setquotpr (carryequiv p (isaprimetoneqO is) ) a) (setquotpr 
(carryequiv p (isaprimetoneqO is) ) b) ) (padictimes p is (setquotpr 
(carryequiv p (isaprimetoneqO is) ) a) (setquotpr (carryequiv p 
(isaprimetoneqO is)) c)) -> prl (padicapart p is) (setquotpr 
(carryequiv p (isaprimetoneqO is) ) b) (setquotpr (carryequiv p 
(isaprimetoneqO is) ) c)) . unfold padictimes . rewrite 2 ! 
setquotprandpadictimes . rewrite 2! padicapartcomputation. intros j . 
apply ( padictimesisbinopapartO p is a b c j ). Defined. 

Lemma padictimesisbinopapartr ( p : hz ) ( is : isaprime p ) : 
isbinopapartr ( padicapart p is ) C padictimes p is ) . Proof, 
intros. unfold isbinopapartr. intros a b c. unfold padictimes. rewrite 
( ®rngcoram2 ( commmgofpadicints p is ) b a ) . rewrite ( 'amgconim2 ( 
commrngof padicints p is ) c a ). apply padictimesisbinopapartl. 
Defined. 

Definition acommrngofpadicints ( p : hz ) ( is : isaprime p ) : 
acommrng. Proof. intros. split with ( commmgofpadicints p is 
), split with ( padicapart p is ) . split, split, apply ( 
padicplusisbinopapartl p is ) . apply ( padicplus isbinopapartr p is ) . 
split, apply ( padictimesisbinopapartl p is ) . apply C 
padictimesisbinopapartr p is ) . Defined. 

(** * IV. The apartness domain of p-adic integers and the Heyting 
field of p-adic numbers *) 

Lemma precarryandzeromultl ( p : hz ) ( is : isaprime p ) ( a b : 
fpscommmg hz ) ( n : nat ) ( x : forall m : nat, natlth m n -> ( 
carry p ( isaprimetoneqO is ) a m ~> OVlhz ) ) : forall m : nat, natlth 
m n -> precarry p ( isaprimetoneqO is ) ( fpstimes hz ( carry p ( 



isaprimetoneqO is ) a ) ( carry p ( isaprimetoneqO is ) b ) ) m "> 
Oyihz. Proof. intros pisabnxmy. induction m. simpl, unfold 
fpstimes. simpl, rewrite ( x 0°/,nat y ), rewrite hzmultOx. apply 
idpath. change ( natsummationO ( S m ) ( fun z : nat => ( carry p ( 
isaprimetoneqO is ) a z ) * ( carry p ( isaprimetoneqO is ) b ( minus 
CSm)z)))+ hzquotientmod p ( isaprimetoneqO is ) ( precarry p ( 
isaprimetoneqO is ) ( fpstimes hz ( carry p ( isaprimetoneqO is ) a ) 
C carry p ( isaprimetoneqO is ) b ) ) m ) ~> 0%hz ) , assert ( natlth 
m n ) as u. apply C istransnatlth _ ( S m ) _ ). apply 
natlthnsn. assumption, rewrite ( IHm u ) . rewrite hzqrandOq. rewrite 
hzplusrO. assert C natsummationO (S m) (fun z : nat => carry p 
(isaprimetoneqO is) a z * carry p (isaprimetoneqO is) b C minus C S m 
) z)) ~> ( natsummationO ( S m ) ( fun z : nat => 0%hz ) ) ) as f . 
apply natsummationpathsupperf ixed, intros k v. assert ( natlth k n ) 
as uu. apply ( natlehlthtrans _ ( S m ) _ 

). assumption, assumption, rewrite ( x k uu ) . rewrite hzmultOx. apply 
idpath. rewrite f. rewrite natsummationaeObottom. apply idpath. intros 
k 1. apply idpath. Defined, 

Lemma precarryandzeromultr ( p : hz ) ( is : isaprime p ) ( a b : 
fpscommrng hz ) ( n : nat ) ( x : forall m : nat, natlth ra n -> ( 
carry p ( isaprimetoneqO is ) b m ~> 07ohz ) ) : forall m : nat, natlth 
m n -> precarry p ( isaprimetoneqO is ) ( fpstimes hz ( carry p ( 
isaprimetoneqO is ) a ) C carry p ( isaprimetoneqO is ) b ) ) m ~> 
0/ihz. Proof. intros p is a b n x ra y. change (fpstimes hz (carry p 
(isaprimetoneqO is) a) (carry p (isaprimetoneqO is) b) ) with ( (carry 
p (isaprimetoneqO is) a) * (carry p (isaprimetoneqO is) b)) . rewrite ( 
( Qrngcomm2 ( fpscommrng hz ) ) ( carry p ( isaprimetoneqO is ) a ) ( 
carry p ( isaprimetoneqO is ) b ) ) . apply C precarryandzeromultl p is 
b a n X m y ) . Defined. 

Lemma hzfpstimesnonzerc ( a : fpscommrng hz ) ( k : nat ) ( is : 
dirprod ( neq hz ( a k ) 0/ihz ) ( forall m : nat, natlth m k -> (am 
) "> OVthz ) ) : forall k' : nat, forall b : fpscommrng hz , forall is' 
: dirprod ( neq hz ( b k' ) 0%hz ) ( forall m : nat, natlth m k' -> ( 
b m ) ~> O'/hz ) , ( a * b ) ( k + k' )7.nat ~> ( a k ) * ( b k' ) . 
Proof. intros a k is k' . induction k' , intros, destruct 
k. simpl, apply idpath, rewrite natplusrO, change ( natsummationO k ( 
fun X : nat => a x * b ( minus (Sk)x) )+a(Sk) *b( minus ( 
Sk) (Sk) ) ~>a(Sk) *b 07,nat ) . assert ( natsummationO k ( 
fun X : nat => a x * b ( minus (Sk)x))~> natsummationO k ( fun 
X : nat => 0%hz ) ) as f . apply natsummationpathsupperf ixed. intros m 
i. assert ( natlth m ( S k ) ) as iO. apply ( natlehlthtrans _ k _ 
). assumption, apply natlthnsn. rewrite ( ( pr2 is ) m iO ) , rewrite 
hzmultOx . apply idpath, rewrite f , rewrite 

natsummationaeObottom. rewrite hzpluslO. rewrite minusnnO. apply 
idpath. intros m i. apply idpath. intros. rewrite natplusnsm. change 
C natsummationO ( k + k* )yaiat ( fun x : nat => a x * b ( minus ( S k 

+ k')x))+a(Sk + k' )7.nat * b ( minus ( S k + k' ) ( S k + k' 
) ) ~> a k * b ( S k' ) ) . set ( b' fpsshift b ). rewrite 
minusnnO. rewrite ( ( pr2 is' ) O^jiat ( natlehlthtrans k' ( S k' ) ( 
natlehOn k' ) ( natlthnsn k' ) ) ) . rewrite hzmultxO, rewrite 
hzplusrO. assert ( natsummationO ( k + k' )linat ( fun x : nat => a x 
* b ( minus (Sk + k')x))~> fpstimes hz a b' ( k + k' )°/,nat ) as 
f. apply natsummationpathsupperf ixed, intros m v. change ( S k + k' 
)linat with (S(k + k' ) ). rewrite <-( pathssminus ( k + k' )%nat m 
). apply idpath. apply ( natlehlthtrans _ ( k + k' )°/,nat _ 
) . assumption, apply natlthnsn. rewrite f , apply ( IHk' b' 
). split, apply is', intros m v. unfold b' . unfold fpsshift. apply 
is' . assumption. Defined. 

Lemma hzfpstimeswhenzero ( a : fpscommrng hz ) ( m k : nat ) ( is : ( 
forall m : nat, natlth m k -> (am) ~> 0%hz ) ) : forall b : 
fpscommrng hz, forall k' : nat, forall is' : ( forall m : nat, natlth 
m k' -> C b m ) ~> O'/hz ) , natlth m ( k + k' )°/nat -> ( a * b ) m ~> 
0*;ihz. Proof, intros a m. induction m. intros k. intros is b k' is' 



j, change C a 0/inat * b 0°/,nat "> 0°/,hz ). destruct k. rewrite ( is' 
Oyjiat j ), rewrite hzmultxO. apply idpath, assert ( natlth ( S k ) ) 
as i . apply ( natlehlthtrans _ k _ ) . apply natlehOn . apply 
natlthnsn. rewrite C is 0%nat i ). rewrite hzmultOx. apply idpath. 

intros k is b k' is' j, change { natsmnmationO ( S m ) ( fun x : nat 
=> a X * b C minus CSm)x) ) ~> 0%hz ). change ( natsummationO 
m C fun X : nat a x * b { minus (Sm)x) )+aCSm) *bC 
minus (Sm) (Sm) ) "> 0°/,hz ) . assert CaCSm)*bC minus ( 
Sm)CSni))~> 0%hz ) as g. destruct k, destruct k' , assert 
empty, apply C negnatgthOn ( S m ) j ) . contradiction, rewrite 
minusnnO. rewrite C is' OXnat C natlehlthtrans OVoiat k' C S k' ) ( 
natlehOn k' ) ( natlthnsn k' ) ) ) . rewrite hzmultxO. apply 
idpath. destruct k' . rewrite natplusrO in j. rewrite (is ( S m ) j 
). rewrite hzmultOx, apply idpath. rewrite minusnnO. rewrite ( is' 
OVtuat ( natlehlthtrans 0%nat k' ( S k' ) ( na'tlehOn k' } ( natlthnsn 
k' ) ) ) . rewrite hzmultxO. apply idpath. rewrite g. rewrite 
hzplusrO. set ( b' ;= fpsshift b ). assert ( natsummationO m C fun x 
: nat => a x * b ( minus CSm)x))~> natsummationO m ( fun x : 
nat => a X * b ' ( minus m x ) ) ) as f . apply 
natsummationpathsupperf ixed, intros n i. unfold b'. unfold 
fpsshift. rewrite pathssminus, apply idpath, apply ( natlehlthtrans 
_ m _ ). assumption, apply natlthnsn. rewrite f. change ( ( a * b' ) 
m ~> OiUiz ), assert ( natlth m(k + k'))as one. apply ( 
istransnatlth _ C S m ) _ ). apply natlthnsn. assumption, destruct 
k' . assert C forall m : nat, natlth m O'/nat -> b' m ~> Oyihz ) as 
two. intros mO jO. assert empty, apply ( negnatgthOn 
mO) . assumption, contradiction, apply ( IHm k is b' O'/oiat two one 
). assert ( forall m : nat, natlth m k* -> b' m ~> OVihz ) as 
two. intros mO jO. change C b C S mO ) ~> OVthz ). apply 
is', assumption, assert ( natlth m C k + k* Y/jiat ) as 
three, rewrite natplusnsm in j. apply j. apply C Il&a k is b' k' two 
three ) , Defined. 

Lemma precarryandzeromult ( p : hz ) C is : isaprime p ) ( a b : 

fpscommrng hz ) ( k k' : nat ) C x ; forall m : nat, natlth m k -> 
carry p ( isaprimetoneqO is ) a m ~> OXhz ) ( x' : forall m : nat, 
natlth m k' -> carry p { isaprimetoneqO is ) b m "> oy,hz ) : forall m 
: nat, natlth m ( k + k' )y,nat -> precarry p ( isaprimetoneqO is ) ( 
fpstimes hz ( carry p ( isaprimetoneqO is ) a ) ( carry p ( 
isaprimetoneqO is ) b ) ) m ~> 0%hz. Proof. intros p is a b k k' x 
X* m i. induction m. apply C hzfpstimeswhenzero C carry p ( 
isaprimetoneqO is ) a ) OVoiat k x ( carry p C isaprimetoneqO is ) b ) 
k' x' i ) . change ( C C carry p ( isaprimetoneqO is ) a ) * C carry p 
C isaprimetoneqO is)b))(Sm)+ hzquotientmod p { isaprimetoneqO 
is ) C precarry p ( isaprimetoneqO is ) ( fpstimes hz ( carry p C 
isaprimetoneqO is ) a ) C carry p ( isaprimetoneqO is ) b ) ) m ) ~> 
0%hz ) . rewrite ( hzfpstimeswhenzero ( carry p ( isaprimetoneqO is ) 
a) CSm)kx( carry p C isaprimetoneqO is ) b ) k' x' i ). rewrite 
hzpluslO. assert ( natlth m ( k + k' )°/,nat ) as one. apply { 
istransnatlth _ ( S m ) _ ). apply natlthnsn. assumption, rewrite ( 
IHm one ). rewrite hzqrandOq. apply idpath. Defined, 

Lemma primedivorcoprime ( p a ; hz ) ( is : isaprime p ) : hdisj ( 

hzdiv p a ) ( gcd p a ( isaprimetoneqO is ) ~> 1 ) . Proof. 

intros, intros P i. apply ( pr2 is C gcd p a ( isaprimetoneqO is ) ) ( 

prl C gcdiscommondiv p a ( isaprimetoneqO is ) ) ) ). intro t. apply 

i. destruct t as [ tO I tl ] . apply ii2. assumption, apply 

iil, rewrite <- tl. exact ( pr2 ( gcdiscommondiv p a ( isaprimetoneqO 

is ) ) ) . Defined. 

Lemma primeandtimes ( p a b : hz ) C is : isaprime p ) C x : hzdiv p C 
a * b ) ) : hdisj ( hzdiv p a ) ( hzdiv p b ). Proof. intros. apply 
C primedivorcoprime p a is ). intros j, intros P i. apply i. destruct 
j as [ jO I jl ]. apply iil. assumption, apply ii2. apply x. intro 
u. destruct u as [ k u ] . unfold hzdivO in u. set { cd := 



bezoutstrong a p ( isaprimetoneqO is ) ) . destruct cd as [ cd f 

]. destruct cd as [ c d ]. rewrite jl in f . simpl in f. assert ( b ~> 

C Cb*c+d*k) *p) ) asg. assert (b~>b*l)asgO. rewrite 

hzmultrl . apply idpath. rewrite gO. rewrite C mgrdistr hz ( b * 1 * c 

) (d*k)p). assert (b* Cc*p+d*a) ~> Cb*l*c*p+d 

*k*p) ) ash. rewrite C mgldistr hz(c*p) Cd*a)b 

). rewrite hzmultrl, rewrite 2! ( Smgassoc2 hz ). rewrite ( Srngcomm2 

hz k p ). change { p * k )°/,hz with ( p * k )'/,rng in u, rewrite 

u. rewrite ( @rngcomm2 hzb Cd*a) ). rewrite ( @rngassoc2 hz 

) . apply idpath. rewrite <- h, rewrite f . apply idpath. intros Q 

uu. apply uu. split with Cb*c + d*k). rewrite C Qmgcomm2 hz _ p 

) in g. unfold hzdivO. apply pathsinvO. assumption. Defined. 

Lemma hzremaindermodprimeandtimes { p : hz ) ( is : isaprime p ) { a b 
: hz ) C X : hzremaindermod p ( isaprimetoneqO is) (a*b) ~>0) : 
hdisj ( hzremaindermod p C isaprimetoneqO is ) a ~> 0) ( 
hzremaindermod p ( isaprimetoneqO is ) b *"> 0) . Proof, 
intros. assert ( hzdiv pCa*b))asi. intros Pi', apply 
i' . split with C hzquotientmod p ( isaprimetoneqO is ) ( a * b ) 
). unfold hzdivO. apply pathsinvO. rewrite <- ( hzplusrO Cp * 
hzquotientmod p (isaprimetoneqO is) (a * b)y,rng) )y,hz, change (a * b 
~> Cp * hzquotientmod p (isaprimetoneqO is) (a + b)y,rng + 0)y,rng) . 
rewrite <- x. change (p * hzquotientmod p (isaprimetoneqO is) (a * b) 
+ hzremaindermod p (isaprimetoneqO is) a * b) with (p * hzquotientmod 
p (isaprimetoneqO is) (a * b)y,rng + ( hzremaindermod p (isaprimetoneqO 
is) a * b )y,rng )y,hz. apply ( hzdivequationmod p ( isaprimetoneqO is ) 
( a * b ) ). apply ( primeandtimes p a b is i ) . intro t. destruct t 
as [to I tl ] . apply tO. intros k. destruct k as [ k k' ]. intros Q 
j. apply j. apply iil. apply pathsinvO. apply C hzqrtestr p C 
isaprimetoneqO is ) a k ), split, rewrite hzplusrO. unfold hzdivO in 
k' . rewrite k' , apply idpath. split, apply isreflhzleh. rewrite 
hzabsvalgthO , apply ( istranshzlth _ 1 _ ). apply hzlthnsn. apply 
is. apply ( istranshzlth _ 1 _ ). apply hzlthnsn, apply is. apply 
tl. intros k. destruct k as [ k k' ]. intros Q j. apply j. apply 
ii2. apply pathsinvO. apply ( hzqrtestr p ( isaprimetoneqO is ) b k ). 
split, rewrite hzplusrO, unfold hzdivO in k' . rewrite k' . apply 
idpath . split . apply isreflhzleh . rewrite hzabsvalgthO . apply ( 
istranshzlth _ 1 _ ). apply hzlthnsn. apply is. apply ( istranshzlth _ 
1 _ ). apply hzlthnsn. apply is. Defined. 

Definition padiczero ( p : hz ) ( is : isaprime p ) := Qrngunell ( 
commmgofpadicints p is ) . 

Definition padicone ( p : hz ) ( is : isaprime p ) := <3mgunel2 ( 
commmgofpadicints p is ) . 

Lemma padiczerocomputation ( p : hz ) ( is : isaprime p ) : padiczero 
p is ~> setquotpr ( carryequiv p ( isaprimetoneqO is ) ) ( Qmgunell C 

fpscommrng hz ) ) . Proof. intros. apply idpath. Defined. 

Lemma padiconecomputation ( p : hz ) ( is : isaprime p ) : padicone p 
is ~> setquotpr ( carryequiv p C isaprimetoneqO is ) ) ( Qmgunel2 ( 
fpscommrng hz ) ) . Proof. intros. apply idpath. Defined, 

Lemma padicintsareintdom ( p : hz ) ( is : isaprime p ) Cab: 
acommrngofpadicints pis) :a#0->b#0->a*b#0. Proof, 
intros p is. assert C forall a b ; commmgofpadicints p is, isaprop C 
C prl C padicapart p is ) ) a ( padiczero p is ) -> ( prl C padicapart 
p is ) ) b C padiczero p is ) -> C prl C padicapart p is ) ) C 
padictimes p is a b ) C padiczero p is ) ) ) as int. intros. apply 
impred. intros. apply impred. intros. apply C prl C padicapart p is ) 

). 

apply C setquotuniv2prop _ C fun x y => hProppair _ C int x y ) ) 
). intros a b. change Cprl Cpadicapart p is) (setquotpr Ccarryequiv 
p C isaprimetoneqO is)) a) Cpadiczero p is) -> prl Cpadicapart p is) 



(setquotpr (carryequiv p (isaprimetoneqO is) ) b) (padiczero p is) -> 
prl (padicapart p is) (padictimGS p is (setquotpr (carryequiv p 
(isaprimetoneqO is) ) a) (setquotpr (carryequiv p (isaprimetoneqO 
is)) b)) (padiczero p is)), unfold padictimes. rewrite 
padiczerocomputation. rewrite setquotprandpadictimes . rewrite 3! 
padicapartcomputation . intros i j . apply i . intros iO . destruct iO 
as [ iO il ] . apply j. intros jO. destruct jOas [jOji]. rewrite 
carryandzero in 11, jl. chajige ( ( Qrngunell ( fpscommrng hz ) ) iO 
) with 0°/,hz in il . chajige ( ( Qrngunell ( fpscommrng hz ) ) jO ) 
with O'/ihz in jl. set ( P := fun x : nat => neq hz ( carry p ( 
isaprimetoneqO is ) a x ) ) . set ( P* := fun x : nat => neq hz ( 
carry p ( isaprimetoneqO is ) b x ) ) . assert ( isdecnatprop P ) 
as isdecl. intros m. destruct ( isdeceqhz ( carry p ( 
isaprimetoneqO is ) am) 0°/,hz ) as [ 1 I r ] . apply ii2. intro 
V. apply V. assumption, apply iil . assumption, assert ( isdecnatprop 
P' ) as isdec2. intros m. destruct ( isdeceqhz ( carry p ( 
isaprimetoneqO is ) b m ) 07Jiz ) as [ 1 I r ] . apply ii2. intro 
V. apply V. assumption, apply iil . assumption. set ( lei := 
leastelementprinciple iO P isdecl il ), set ( le2 ;= 
leastelementprinciple jO P' isdsc2 jl ). apply lei. intro 
k. destruct k as [ k k' ]. apply le2. intro o. destruct o as [ o o' 
]. apply total2tohexists . split with ( k + o )iinat. 

assert ( forall m : nat, natlth m k -> carry p ( isaprimetoneqO is ) 
a m ~> 0°/Shz ) as one. intros m mO. destruct ( isdeceqhz ( carry p ( 
isaprimetoneqO is ) am) O'/hz ) as [ leftO 1 rightO ] . assumption, 
assert empty, apply ( ( pr2 k' ) m mO ) . assumption, contradiction, 
assert ( forall m : nat, natlth m o -> carry p ( isaprimetoneqO is ) 
b m "> 0%hz ) as two. intros m mO. destruct ( isdeceqhz ( carry p ( 
isaprimetoneqO is ) b m ) OVJiz ) as [ leftO I rightO ]. assumption, 
assert empty, apply ( ( pr2 o' ) m mO ) . assumption, contradiction, 
assert ( dirprod ( neq hz ( carry p ( isaprimetoneqO is ) a k ) 0'/,hz 
) ( forall m : nat, natlth m k -> ( carry p ( isaprimetoneqO is ) a 
m ) ~> OXhz ) ) as three, split, apply k' . assumption, assert ( 
dirprod ( neq hz ( carry p ( isaprimetoneqO is ) b o ) 0%hz ) ( 
forall m : nat, natlth m o -> ( carry p ( isaprimetoneqO is ) b m ) 
~> O^ihz ) ) as four, split, apply o'. assumption, set ( f : = 
hzfpstimesnonzero ( carry p ( isaprimetoneqO is ) a ) k three o ( 
carry p ( isaprimetoneqO is ) b ) four ) . rewrite 

carryandzero. change ( ( ©rngunell ( fpscommrng hz ) ) ( k + o )iinat 
) with 0%hz. rewrite carryandtimes. 

destruct k. destruct o. rewrite <- carryandtimes. intros v. change ( 
hzremaindermod p ( isaprimetoneqO is ) ( a O'/nat * b 0/inat ) ~> O'/hz 
) in V. assert hfalse, apply ( hzremaindermodprimeandtimes p is ( a 
0/inat ) ( b OXnat ) v ). intros t. destruct t as [ tO I tl ] . apply 
( prl k' ). apply tO. apply ( prl o' ). apply tl. assumption. 



intros v. unfold carry at 1 in v. change ( + S o )ytnat with (So 



) in V. change ( hzremaindermod p ( isaprimetoneqO is ) ( ( carry p 
C isaprimetoneqO is ) a * carry p ( isaprimetoneqO is)b) (So) 
+ hzquotientmod p ( isaprimetoneqO is ) ( precarry p ( 
isaprimetoneqO is ) ( carry p ( isaprimetoneqO is ) a * carry p ( 
isaprimetoneqO is ) b ) o ) ) ~> 0°/,hz ) in v, change ( + S o 
)%nat with (So) in f , rewrite f in v. change ( carry p ( 
isaprimetoneqO is ) a * carry p ( isaprimetoneqO is ) b ) with ( 
fpstimes hz ( carry p ( isaprimetoneqO is ) a ) ( carry p ( 
isaprimetoneqO is ) b ) ) in v. rewrite ( precarryandzeromult p is 
a b 0/inat (So) ) in v. rewrite hzqrandOq in v. rewrite hzplusrO 
in V. assert hfalse. apply ( hzremaindermodprimeandtimes p is ( 
carry p ( isaprimetoneqO is ) a O'/nat ) ( carry p ( isaprimetoneqO 
is)b(So) ) ). assumption, intros s. destruct s as [1 I r ]. 
apply k' . rewrite hzqrandcarryr , assumption, apply o' , rewrite 
hzqrandcarryr . assumption. assumption, apply one. apply two. apply 
natlthnsn . 

intros v. unfold carry at 1 in v, change ( hzremaindermod p ( 
isaprimetoneqO is ) ( ( carry p ( isaprimetoneqO is ) a * carry p ( 
isaprimetoneqO is)b) (Sk+o )Xnat + hzquotientmod p ( 
isaprimetoneqO is ) ( precarry p ( isaprimetoneqO is ) ( carry p ( 
isaprimetoneqO is ) a * carry p ( isaprimetoneqO is)b) (k+o 
)%nat ) ) ~> OXhz ) in v. rewrite f in v, change ( carry p ( 
isaprimetoneqO is ) a * carry p ( isaprimetoneqO is ) b ) with ( 
fpstimes hz ( carry p ( isaprimetoneqO is ) a ) ( carry p ( 
isaprimetoneqO is ) b ) ) in v. rewrite ( precarryajidzeromult p is 
ab(Sk)o)inv. rewrite hzqrandOq in v, rewrite hzplusrO in 
V. assert hfalse. apply ( hzremaindermodprimeandtimes p is ( carry p 
C isaprimetoneqO is)a(Sk)) ( carry p ( isaprimetoneqO is ) b 
(o ) ) ). assumption, intros s. destruct s as [1 I r ]. apply 
k' , rewrite hzqrandcarryr. assumption, apply o'. rewrite 
hzqrajidcarryr , assumption. assumption, apply one. apply two. apply 
natlthnsn . Def ined . 

Definition padicintegers ( p : hz ) ( is : isaprime p ) : aintdom. 
Proof. intros. split with ( acommmgofpadicints p is ) , split, 
change ( ( prl ( padicapart p is ) ) ( padicone p is ) ( padiczero p 
is ) ) . rewrite ( padiczerocomputation p is ) , rewrite ( 
padiconecomputation p is ) . rewrite padicapartcomputation, apply 
total2tohexists , split with O/inat , unfold carry, unfold 
precarry. rewrite hzqrandlr. rewrite hzqrandOr. apply isnonzeromghz. 
apply padicintsareintdom. Defined. 

Definition padics ( p : hz ) ( is : isaprime p ) : afld := afldfrac ( 
padicintegers p is ) . 

Close Scope rng_scope. 
(** END OF FILE*) 
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